Commit 74df57e2 authored by Dave Cooper's avatar Dave Cooper

restarting manual effort

parent 5cd11129
......@@ -28,7 +28,8 @@
;;(defparameter *gendl-version* "1587p005")
;;(defparameter *gendl-version* "1587p006")
;;(defparameter *gendl-version* "1587p007")
(defparameter *gendl-version* "1587p008")
;;(defparameter *gendl-version* "1587p008")
(defparameter *gendl-version* "1587p009")
;;(defparameter *gendl-version* "ql-2013-12")
(defparameter *gendl-patch-level* nil)
......
......@@ -22,16 +22,17 @@
(in-package :gdl-user)
#+nil
(defun dmapcar (function list)
(dmapc function list)
(mapcar function list))
#+nil
(defun dmapc (function list)
(let ((count -1))
(mapc #'(lambda(element)
(let ((element element))
(bt:make-thread function :name (format nil "thread ~a from dmapcar" (incf count)))))
(mapc #'(lambda ()
(bt:make-thread function :name (format nil "thread ~a from dmapcar" (incf count))))
list)))
......@@ -46,7 +47,7 @@
(height 30)
(hole-radius 2 :settable)
(hole-length 35)
(quantity 3 :settable))
(quantity 2 :settable))
:computed-slots
......@@ -79,7 +80,10 @@
(
(collect-volumes
(&key remote?)
()
;;(&key remote?)
#+nil
(dmapcar #'(lambda(drilled-block) (the-object drilled-block volume))
(list-elements (if remote? (the remote-drilled) (the local-drilled)))))
......@@ -98,11 +102,8 @@
(global-gc
()
(gc t))
(reload
()
(gdl-user::g105))))
(glisp:gc-full))))
......@@ -113,17 +114,13 @@
(quantity 50 :settable))
:computed-slots ((volume (sum-elements (the results) (the-element volume)))
(c-of-g (the results center-of-gravity))
)
:computed-slots ((volume (the result volume))
(c-of-g (the result center-of-gravity)))
:objects
((results :type 'subtracted-solid
;;:sequence (:size (the quantity))
:pass-down (brep other-brep))
((result :type 'subtracted-solid
:pass-down (brep other-brep))
(brep :type 'box-solid
:display-controls (list :color :green))
......@@ -132,12 +129,7 @@
(other-brep :type 'cylinder-solid
:radius (the hole-radius)
:length (the hole-length)
:display-controls (list :color :green)))
:functions
((cl!
()
(load (compile-file-if-needed "~/genworks/training/g105/examples/source/drilled-block.lisp")))))
:display-controls (list :color :green))))
(eval-when (:compile-toplevel :load-toplevel :execute)
......
This source diff could not be displayed because it is too large. You can view the blob instead.
......@@ -64,16 +64,33 @@ written consent from Genworks International.")
,*advanced-common-lisp*
,*advanced-gendl*
,*upgrade-notes*
,(the-object (make-self 'yadd::assy) dom-chapter)
;;,(the-object (make-self 'yadd::assy) dom-chapter)
:backmatter
,*bibliography*
:printindex
)))
(defmacro run-prog (command)
`(multiple-value-bind (output error return-code)
(uiop:run-program ,command :output :string :error :string :ignore-error-status t)
(when (or error (not (zerop return-code)))
(format t "Command was: ~a~%" ,command)
(warn "Error was ~a, ~a and return-code was ~a" output error return-code))))
(defun make (&optional (level 1))
(let ((pdf-path (merge-pathnames "pdf/" *system-home*)))
(let ((pdf-path (merge-pathnames "pdf/" *system-home*))
(pdftex-path (cond ((probe-file "/usr/texbin/pdflatex")
"/usr/texbin/pdflatex")
((probe-file "/opt/local/bin/pdflatex")
"/opt/local/bin/pdflatex")))
(makeindex-path (or (probe-file "/usr/texbin/makeindex")
(probe-file "/opt/local/bin/makeindex"))))
(load (merge-pathnames "../source/assembly.lisp" pdf-path))
......@@ -83,23 +100,13 @@ written consent from Genworks International.")
(ensure-directories-exist (translate-logical-pathname pdf-path))
(with-format (com.genworks.dom-writers:latex (merge-pathnames "pdf/tutorial.tex" *system-home*))
(write-the-object object (:base))))
;;
;; FLAG - replace this asdf:run-shell-command with glisp:run-shell-command or uiop:run-program.
;;
(asdf:run-shell-command
;;(format nil "cd ~a; /opt/local/bin/pdflatex -interaction=nonstopmode tutorial.tex" pdf-path)
(format nil "cd ~a; pdflatex -interaction=nonstopmode tutorial.tex" pdf-path)
)
(asdf:run-shell-command
(format nil "cd ~a; makeindex tutorial" pdf-path))
(dotimes (n level)
(asdf:run-shell-command
(format nil "cd ~a; pdflatex -interaction=nonstopmode tutorial.tex" pdf-path)))))
(run-prog (format nil "cd ~a; ~a -interaction=nonstopmode tutorial.tex" pdf-path pdftex-path))
(run-prog (format nil "cd ~a; ~a tutorial" pdf-path makeindex-path))
(dotimes (n level)
(run-prog (format nil "cd ~a; ~a -interaction=nonstopmode tutorial.tex"
pdf-path pdftex-path)))))
(define-object assembly (com.genworks.dom:assembly)
:input-slots ((data *data*)))
......
......@@ -375,7 +375,7 @@ load the system using Quicklisp. To do this for our example, follow these steps:
((:list :style :enumerate)
(:item (:verbatim "(cl-lite \"apps/yoyodyne/\" :create-asd-file? t)")
" to generate the asdf file for the yoyodyne system. This only has to be done once after every time you add, remove, or rename a file or folder from the system.")
(:item (:verbatim "(pushnew \"apps/yoyodyne/\" ql:*local-project-directories*)")
(:item (:verbatim "(pushnew \"apps/yoyodyne/\" ql:*local-project-directories* :test #'equalp)")
" This can be done in your "
(:texttt "gdlinit.cl")
" for projects you want available during every development session. Note that you should include
......@@ -417,19 +417,22 @@ To save a world, follow these steps:"
((:list :style :enumerate)
(:item "Load the base GDL code and (optionally) code for GDL
modules (e.g. gdl-yadd, gdl-tasty) you want to be in your saved image. For example:"
modules (e.g. gdl-yadd, gdl-tasty) you want to be in your saved
image. Note that in some implementations, this has step to be done in
a plain session without multiprocessing (i.e. without an Emacs
connection) - so you would do this loading step from a command shell
e.g. Windows cmd prompt. For example:"
(:verbatim "
(ql:quickload :gdl-yadd)
(ql:quickload :gdl-tasty)"))
:item (:verbatim "(ff:unload-foreign-library (merge-pathnames \"smlib.dll\" \"sys:smlib;\"))")
:item (:verbatim "(net.aserve:shutdown)")
:item (:verbatim "(setq excl:*restart-init-function* '(gdl:start-gdl :edition :trial))")
(:item "(needed only for full GDL):" (:verbatim "(ff:unload-foreign-library (merge-pathnames \"smlib.dll\" \"sys:smlib;\"))"))
(:item (:verbatim "(net.aserve:shutdown)"))
(:item " (to save an image named yoyodyne.dxl) Invoke the command "
(:verbatim "(dumplisp :name \"yoyodyne.dxl\")")
(:verbatim "(ensure-directories-exist \"~/gdl-images/\")")
(:verbatim "(uiop:dump-image dumplisp \"~/gdl-images/yoyodyne\")")
"Note that the standard extension for Allegro CL images is "
(:texttt ".dxl")
". Prepend the file name with path information, to write the image to a specific location.")))
......@@ -439,7 +442,7 @@ modules (e.g. gdl-yadd, gdl-tasty) you want to be in your saved image. For examp
"In order to start up GDL using a custom saved image, or ``world,'' follow these steps"
((:list :style :enumerate)
(:item "Exit GDL")
(:item "Copy the supplied "
(:item "Copy the supplied image file, e.g."
(:texttt "gdl.dxl")
" to "
(:texttt "gdl-orig.dxl")
......
......@@ -164,7 +164,8 @@ have open-source Gendl or a lite Trial version of Genworks GDL, these
regression tests will not all function.
In Emacs at the "
(:texttt "gdl-user>")
;;(:texttt "gdl-user>")
(:texttt "gdl-user")
" prompt in the "
(:texttt "*slime-repl...*") " buffer, type the following commands:"
((:list :style :enumerate)
......
......@@ -360,7 +360,7 @@ the arguments to the "
(:texttt "list")
" function get evaluated, from left to right, before being
processed by the function. For example:"
(:verbatim "(list ’a ’b (+ 2 2))")
(:verbatim "(list 'a 'b (+ 2 2))")
"will return the list"
(:verbatim "(a b 4)")
"The two quoted symbols evaluate to symbols, and the function
......
(:glisp :aserve)
(:bordeaux-threads :glisp :aserve)
......@@ -3,7 +3,7 @@
(asdf:defsystem #:gwl :description
"The Gendl\" Generative Web Language (GWL)" :author "John McCarthy"
:license "Affero Gnu Public License (http://www.gnu.org/licenses/)"
:serial t :version "20140916" :depends-on (:glisp :aserve)
:serial t :version "20140916" :depends-on (:bordeaux-threads :glisp :aserve)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -175,7 +175,7 @@ the browser in development mode). Defaults to NIL (the empty list)."
(the :instance-id) (the (compute-url))))))
(publish
:path url
:content-type "text/html"
:content-type "text/html; charset=UTF-8"
:host (the host)
:function #'(lambda (req ent)
(the before-response!)
......
......@@ -25,6 +25,11 @@
(defparameter *bug* nil)
(defparameter *remote-hash-lock* (bt:make-lock "remote-hash-lock"))
(defparameter *remote-proxy-lock* (bt:make-lock "remote-proxy-lock"))
(defparameter *remote-evaluate-lock* (bt:make-lock "remote-evaluate-lock"))
(defparameter *remote-fetch-input-lock* (bt:make-lock "remote-fetch-input-lock"))
(with-all-servers (server)
(publish-file :path "/favicon.ico"
:server server
......@@ -38,48 +43,49 @@
(publish :path "/fetch-remote-input"
:function
#'(lambda(req ent)
(let* ((query (request-query req))
(args (rest (assoc "args" query :test #'string-equal)))
(*ipaddr* (socket:ipaddr-to-dotted (socket:remote-host (request-socket req)))))
(let ((args-list (base64-decode-list args)))
;;
;; FLAG -- consider a warning if package not found
;;
(let ((*package* (or (find-package (getf args-list :package)) *package*)))
(let ((object (the-object (gethash (getf args-list :remote-id) *remote-objects-hash*)
(follow-root-path (getf args-list :remote-root-path))))
(child (evaluate-object (first (getf args-list :child)) (rest (getf args-list :child))))
(message (getf args-list :message))
(gdl::*notify-cons* (decode-from-http (getf args-list :notify-cons)))
(part-name (getf args-list :part-name))
(args (getf args-list :args)))
(glisp:with-heuristic-case-mode ()
(with-http-response (req ent)
(with-http-body (req ent)
(let ((value (if object (multiple-value-bind (value error)
(ignore-errors
(apply (symbol-function (glisp:intern message :gdl-inputs))
object (glisp:intern part-name :gdl-acc) child args))
(if (typep error 'error)
(let ((error-string
(glisp:replace-regexp
(format nil "~a" error) "\\n" " ")))
(cond ((or (search "could not handle"
error-string)
#+nil
(search "which is the root"
error-string)
(search "instances could handle"
error-string))
'gdl-rule:%not-handled%)
(t (when *debug?*
(format t "Throwing error on fetch-input server because gwl::*debug?* is set to non-nil~%")
(error error))
(list :error (format nil "~a" error)))))
value))
(list :error :no-such-object (getf args-list :remote-id)))))
(let ((encoded-value (base64-encode-safe (format nil "~s" (encode-for-http value)))))
(html (format *html-stream* encoded-value)))))))))))))
(bt:with-lock-held (*remote-fetch-input-lock*)
(let* ((query (request-query req))
(args (rest (assoc "args" query :test #'string-equal)))
(*ipaddr* (socket:ipaddr-to-dotted (socket:remote-host (request-socket req)))))
(let ((args-list (base64-decode-list args)))
;;
;; FLAG -- consider a warning if package not found
;;
(let ((*package* (or (find-package (getf args-list :package)) *package*)))
(let ((object (the-object (gethash (getf args-list :remote-id) *remote-objects-hash*)
(follow-root-path (getf args-list :remote-root-path))))
(child (evaluate-object (first (getf args-list :child)) (rest (getf args-list :child))))
(message (getf args-list :message))
(gdl::*notify-cons* (decode-from-http (getf args-list :notify-cons)))
(part-name (getf args-list :part-name))
(args (getf args-list :args)))
(glisp:with-heuristic-case-mode ()
(with-http-response (req ent)
(with-http-body (req ent)
(let ((value (if object (multiple-value-bind (value error)
(ignore-errors
(apply (symbol-function (glisp:intern message :gdl-inputs))
object (glisp:intern part-name :gdl-acc) child args))
(if (typep error 'error)
(let ((error-string
(glisp:replace-regexp
(format nil "~a" error) "\\n" " ")))
(cond ((or (search "could not handle"
error-string)
#+nil
(search "which is the root"
error-string)
(search "instances could handle"
error-string))
'gdl-rule:%not-handled%)
(t (when *debug?*
(format t "Throwing error on fetch-input server because gwl::*debug?* is set to non-nil~%")
(error error))
(list :error (format nil "~a" error)))))
value))
(list :error :no-such-object (getf args-list :remote-id)))))
(let ((encoded-value (base64-encode-safe (format nil "~s" (encode-for-http value)))))
(html (format *html-stream* encoded-value))))))))))))))
(publish :path "/unbind-slots"
......@@ -125,7 +131,7 @@
(with-http-response (req ent)
(with-http-body (req ent)
(let ((value (if object (multiple-value-bind (value error)
(glisp:w-o-interrupts
(bt:with-lock-held (*remote-evaluate-lock*)
(ignore-errors (if args
(the-object object ((evaluate message)
(:apply args)))
......@@ -180,67 +186,69 @@
(publish :path "/make-remote-object"
:function
#'(lambda(req ent)
(let* ((query (request-query req))
(ipaddr (socket:ipaddr-to-dotted (socket:remote-host (request-socket req))))
(*ipaddr* (socket:ipaddr-to-dotted (socket:remote-host (request-socket req))))
(args (rest (assoc "args" query :test #'string-equal))))
(let ((args-list (base64-decode-list args)))
(when *debug?*
(format t "~%In make-remote-object response func:~%")
(print-variables args-list))
(let ((*package* (or (find-package (getf args-list :package)) *package*))
(name (getf args-list :name))
(index (getf args-list :index))
(rest-args (remove-plist-keys args-list
(list :parent-form :current-id :name :index
:type :package :host :port)))
(current-id (getf args-list :current-id))
(parent-form (getf args-list :parent-form)))
(setf (getf (rest parent-form) :host) ipaddr)
(when current-id
(let ((removed? (remhash current-id *remote-objects-hash*)))
(when removed?
(format t "~&~%Removed stale remote object with ID ~s.~%~%" current-id))))
(let ((object (make-object (read-safe-string (getf args-list :type))
:type (read-safe-string (getf args-list :type))))
(new-id (make-keyword (make-new-instance-id))))
(the-object object (set-slot! :%name% name :warn-on-non-toplevel? nil))
(the-object object (set-slot! :remote-id new-id :remember? nil :warn-on-non-toplevel? nil))
(the-object object (set-slot! :%index% index :warn-on-non-toplevel? nil))
(setf (slot-value object 'gdl-acc::%parent%)
(list (evaluate-object (first parent-form) (rest parent-form)) nil t))
(setf (gethash new-id *remote-objects-hash*) object)
(format t "~&~%Created new remote object with ID ~s and arglist:
(bt:with-lock-held (*remote-hash-lock*)
(let* ((query (request-query req))
(ipaddr (socket:ipaddr-to-dotted (socket:remote-host (request-socket req))))
(*ipaddr* (socket:ipaddr-to-dotted (socket:remote-host (request-socket req))))
(args (rest (assoc "args" query :test #'string-equal))))
(let ((args-list (base64-decode-list args)))
(when *debug?*
(format t "~%In make-remote-object response func:~%")
(print-variables args-list))
(let ((*package* (or (find-package (getf args-list :package)) *package*))
(name (getf args-list :name))
(index (getf args-list :index))
(rest-args (remove-plist-keys args-list
(list :parent-form :current-id :name :index
:type :package :host :port)))
(current-id (getf args-list :current-id))
(parent-form (getf args-list :parent-form)))
(setf (getf (rest parent-form) :host) ipaddr)
(when current-id
(let ((removed? (remhash current-id *remote-objects-hash*)))
(when removed?
(format t "~&~%Removed stale remote object with ID ~s.~%~%" current-id))))
(let ((object (make-object (read-safe-string (getf args-list :type))
:type (read-safe-string (getf args-list :type))))
(new-id (make-keyword (make-new-instance-id))))
(the-object object (set-slot! :%name% name :warn-on-non-toplevel? nil))
(the-object object (set-slot! :remote-id new-id :remember? nil :warn-on-non-toplevel? nil))
(the-object object (set-slot! :%index% index :warn-on-non-toplevel? nil))
(setf (slot-value object 'gdl-acc::%parent%)
(list (evaluate-object (first parent-form) (rest parent-form)) nil t))
(setf (gethash new-id *remote-objects-hash*) object)
(format t "~&~%Created new remote object with ID ~s and arglist:
~s~%~%"
new-id rest-args)
(with-http-response(req ent)
(with-http-body (req ent) (html (format *html-stream* "~s" new-id))))))))))
new-id rest-args)
(with-http-response(req ent)
(with-http-body (req ent) (html (format *html-stream* "~s" new-id)))))))))))
(defmethod evaluate-object ((category (eql :remote-gdl-instance)) args)
(let ((hash-key (list (getf args :id) (getf args :root-path))))
(or (gethash hash-key gwl::*remote-proxies-hash* )
(progn
(format t "~%~%~s Not found in hash - creating fresh ~%~%" (getf args :id))
(setf (gethash hash-key *remote-proxies-hash*)
(gdl::make-object-internal 'remote-object
:%parent% (list nil nil t)
:%index% (list (getf args :index) nil t)
:remote-id (list (getf args :id) nil t)
:host (list (or *ipaddr* (getf args :host)) nil t)
:port (list (getf args :port) nil t)
:remote-root-path (list (getf args :root-path) nil t)
:remote-type (list (multiple-value-bind (result error)
(ignore-errors (read-from-string (getf args :type)))
(if (typep error 'error) :unknown result)) nil t)))))))
(bt:with-lock-held (*remote-proxy-lock*)
(or (gethash hash-key gwl::*remote-proxies-hash* )
(progn
(format t "~%~%~s Not found in hash - creating fresh ~%~%" (getf args :id))
(setf (gethash hash-key *remote-proxies-hash*)
(gdl::make-object-internal 'remote-object
:%parent% (list nil nil t)
:%index% (list (getf args :index) nil t)
:remote-id (list (getf args :id) nil t)
:host (list (or *ipaddr* (getf args :host)) nil t)
:port (list (getf args :port) nil t)
:remote-root-path (list (getf args :root-path) nil t)
:remote-type (list (multiple-value-bind (result error)
(ignore-errors (read-from-string (getf args :type)))
(if (typep error 'error) :unknown result)) nil t))))))))
......
gwl/static/gwl/images/add-item.png

289 Bytes | W: | H:

gwl/static/gwl/images/add-item.png

439 Bytes | W: | H:

gwl/static/gwl/images/add-item.png
gwl/static/gwl/images/add-item.png
gwl/static/gwl/images/add-item.png
gwl/static/gwl/images/add-item.png
  • 2-up
  • Swipe
  • Onion skin