Commit 090e65d7 authored by Teodor Gelu Chiciudean's avatar Teodor Gelu Chiciudean
Browse files

Merge remote-tracking branch 'upstream/master'

parents 64e30197 d506336b
# Lines starting with '#' are considered comments.
# Ignore any file named foo.txt.
*.fasl
*.xfasl
bin
*~
.DS_Store
......
Clean startup on Ubuntu Linux (replace apt-get with the package manager
on your local Linux):
======================
on your local Linux or MacOS):
==============================
$ == Linux shell prompt
* == Common Lisp shell prompt
......@@ -26,11 +26,12 @@ $ sbcl --load cl/quicklisp.lisp
$ emacs
M-x slime
* (load "~/quicklisp/setup")
* (load "~/Genworks-GDL/ql-register-local-project")
* (pushnew (make-pathname :name nil :type nil
:defaults "~/Genworks-GDL/")
ql:*local-project-directories*)
* (ql:register-local-projects)
* (ql:quickload :gdl-all)
* (ql:quickload :gdl-surf) ;; optional -- provides VRML and X3DOM output - under development!
# [In web browser: visit: http://localhost:9000/tasty]
# [In field for package::class, enter robot:assembly]
# [click pencil icon next to Robot (shows up on mouseover]
(in-package :wire-world)
(define-object assembly (base-object)
:objects
((hangar :type 'hangar
:orientation (alignment :top (the (face-normal-vector :rear)))
:center (translate (the center)
:right (half (the-child width))
:front (half (the-child height))))
(mudball :type 'sphere
:display-controls (list :color :brown)
:radius 3
:inner-radius 2.5
;;:end-horizontal-arc pi
:start-vertical-arc 0
:end-vertical-arc (/ pi 4)
:center (translate (the center) :left 10 :rear 10 :up (the-child radius)))
(ground :type 'ground
:height 0 :length 50 :width (* +phi+ 50))
(tree :type 'tree
:center (translate (the center) :left 12 :front 12 :top (half (the-child length)))
:orientation (alignment :rear (the (face-normal-vector :top)))
:length 7
:radius-1 3 :radius-2 0)
(teepee :type 'teepee
:center (translate (the center) :right 4 :front 12 :top (half (the-child length)))
:orientation (alignment :rear (the (face-normal-vector :top)))
:length 3
:arc (* 3/2 pi)
:radius-1 2 :radius-2 0.5
:inner-radius-1 1.8 :inner-radius-2 0.3)
(traffic-cone :type 'traffic-cone
:center (translate (the center) :left 5 :up (half (the-child length)))
:orientation (alignment :rear (the (face-normal-vector :top)))
:length 1
:radius-1 0.5
;;:arc pi
)
(reactor :type 'spherical-cap
:display-controls (list :color :purple )
:base-radius 3
:axis-length 2
:center (translate (the center)
:up (half (the-child height))
:left 17 :front 5))
(waterslide :type 'route-pipe
:vertex-list (list (make-point 20 20 20)
(make-point 20 19 15)
(make-point 18 19 10)
(make-point 18 16 5))
:default-radius 5
:outer-pipe-radius 1
:inner-pipe-radius 0.8
:display-controls (list :color :blue-steel
:transparency 0.3
:shininess 0.7
:spectral-color :white))
(silo :type 'silo
:radius 1
;;:arc (* 3/2 pi)
:length 5
:orientation (alignment :rear (the (face-normal-vector :top)))
:center (translate (the center) :right 4 :rear 12 :top (half (the-child length))))))
(define-object traffic-cone (cone)
:computed-slots ((display-controls (list :color :yellow))))
(define-object silo (base-object)
:input-slots (radius)
:computed-slots ((display-controls (list :color :blue)))
:objects
((roof :type 'sphere
:display-controls (list :color :orange)
:center (translate (the center) :rear (half (the length)))
:end-horizontal-arc pi
:pass-down (radius)
)
(tower :type 'cylinder
:display-controls (append (the display-controls) (list :transparency 0.9))
:pass-down (radius length))))
(define-object teepee (cone)
:computed-slots ((display-controls (list :color :brown))
(bottom-cap? nil)
(closed? t)))
(define-object tree (cone)
:computed-slots ((display-controls (list :color :green-forest))))
(define-object ground (box)
:computed-slots ((display-controls (list :color :green-lime :transparency 0.3))))
(define-object hangar (base-object)
:computed-slots ((display-controls (list :color :grey :transparency 0.7))
(width (- (apply #'max (mapcar #'get-x (the vertex-list-local)))
(apply #'min (mapcar #'get-x (the vertex-list-local)))))
(height (the shape projection-depth))
(length (- (apply #'max (mapcar #'get-y (the vertex-list-local)))
(apply #'min (mapcar #'get-y (the vertex-list-local)))))
(vertex-list-local (list (make-point 0 0 0)
(make-point 2 2 0)
(make-point 4 3 0)
(make-point 6 2 0)
(make-point 8 0 0)))
(vertex-list (mapcar #'(lambda(point)
(the (local-to-global point)))
(the vertex-list-local))))
:objects
((shape :type 'global-polygon-projection
:vertex-list (the vertex-list)
:projection-depth 10
:projection-vector (the (face-normal-vector :top)))))
(in-package :common-lisp-user)
(gdl:define-package :wire-world (:export #:assembly))
......@@ -23,7 +23,7 @@
(define-object part-type-form (base-html-sheet)
:input-slots
((object-type "gwl-user::tasty-test-part" :settable)
((object-type "robot:assembly" :settable)
make-instance-function set-root-function tatu-root package-default)
:computed-slots
......
......@@ -33,14 +33,14 @@
(part-type 'function-dokumentation)
(symbols (remove-duplicates
(let (result (package-object (the :package-object)))
(do-symbols (symbol (the :package)
(do-symbols (sym (the :package)
(sort (nreverse result) #'string< :key #'symbol-name))
(when (and (eql (symbol-package symbol) package-object)
(glisp:function-documentation symbol))
(push symbol result))))))
(when (and (eql (symbol-package sym) package-object)
(glisp:function-documentation sym))
(push sym result))))))
(symbols-external (remove-duplicates
(let (result (package-object (the :package-object)))
(do-external-symbols (symbol
(do-external-symbols (sym
(the :package)
(sort
......@@ -49,9 +49,9 @@
:key
#'symbol-name))
(when (and (eql (symbol-package symbol) package-object)
(glisp:function-documentation symbol))
(push symbol result))))))))
(when (and (eql (symbol-package sym) package-object)
(glisp:function-documentation sym))
(push sym result))))))))
(define-object function-dokumentation (doc-string-parser-mixin
......@@ -77,14 +77,14 @@
(:title
(:princ
(format nil "~a: ~s" (if (the macro?) "Macro" "Function")
(the :symbol)))))
(the symbol)))))
(:body (when *developing?* (html (:p (the (write-development-links)))))
;;(when *adsense?* (html (:p (:princ *adsense-code*))))
(:p (when (the :return-object) (the (:write-back-link :display-string "&lt;-Back"))))
(:h2
(:princ
(format nil "~a: ~:(~s~)" (if (the macro?) "Macro" "Function")
(the :symbol))))
(the symbol))))
(:p
((:table :width "100%" :border 0 :cellpadding 1 :cellspacing 0)
(the (:write-row :show-package? (the :show-package?)))))
......@@ -95,7 +95,7 @@
(&key show-package?)
(html (:tr
((:td :align :left)
(:b (:princ (format nil "~a" (the :symbol))))
(:b (:princ (format nil "~a" (the symbol))))
(when (getf (the :section-plist) :type)
(html " "
(:i
......@@ -105,7 +105,7 @@
(:tr
((:td :colspan 2)
(the (:write-remark-body (the :section-plist) :show-package
(when show-package? (symbol-package (the :symbol)))))))
(when show-package? (symbol-package (the symbol)))))))
(:tr ((:td :colspan 2) :br))))
(remark-string
......
......@@ -24,6 +24,7 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(defpackage :com.genworks.lisp
(:use :common-lisp)
(:nicknames :glisp)
(:export #:autoloaded-packages
#:package-documentation
#:function-documentation
......@@ -39,20 +40,18 @@
#-(or allegro lispworks sbcl) (error "Need implementation for package-documentation for the currently running Lisp.~%")
(defun package-documentation (package)
(#+(or allegro lispworks) documentation
#+sbcl sb-kernel:package-doc-string
(find-package package)
#+allegro 'package))
#+(or allegro lispworks) (documentation (find-package package) t)
#+sbcl (sb-kernel:package-doc-string (find-package package)))
#-(or allegro lispworks sbcl cmu) (error "Need implementation for function-documentation for the currently running Lisp.~%")
(defun function-documentation (function-symbol)
#+allegro (get function-symbol 'excl::%fun-documentation)
#+lispworks (get symbol 'system::%fun-documentation)
#+lispworks (get function-symbol 'system::%fun-documentation)
#+(or cmu sbcl) (documentation function-symbol 'function))
#-(or allegro lispworks sbcl cmu) (error "Need implementation for variable-documentation for the currently running Lisp.~%")
(defun variable-documentation (function-symbol)
#+allegro (get function-symbol 'excl::%var-documentation)
#+lispworks (get symbol 'system::%var-documentation)
#+lispworks (get function-symbol 'system::%var-documentation)
#+(or cmu sbcl) (documentation function-symbol 'variable))
......@@ -97,4 +97,4 @@
(pushnew #'initialize-gdl *gdl-init-functions*)
(glisp:set-default-float-format)
(glisp:set-defpackage-behavior)
......@@ -164,7 +164,7 @@ Removing output function: ~a for view of format: ~a on object definition: ~s wit
,(if has-declare? (first body) `(declare))
(block ,(make-keyword attr-sym) ,@(if has-declare? (rest body) body))) ,args-arg))))
(declare (ignorable ,method))
(eval-when (compile load eval) (glisp:begin-redefinitions-ok))
(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:begin-redefinitions-ok))
,(when (and *compile-for-dgdl?* (not remote?))
`(defmethod ,attr-sym ((format ,format) (self gdl-remote) (skin ,skin) &rest ,args-arg)
,(when (and *compile-documentation-database?* attr-remarks) attr-remarks)
......@@ -173,7 +173,7 @@ Removing output function: ~a for view of format: ~a on object definition: ~s wit
(block ,(make-keyword attr-sym)
(the (send-output (:apply (cons ,(make-keyword attr-sym)
(cons *%format%* ,args-arg))))))))))
(eval-when (compile load eval) (glisp:end-redefinitions-ok))
(eval-when (:compile-toplevel :load-toplevel :execute) (glisp:end-redefinitions-ok))
,(when (and *compile-documentation-database?* attr-remarks)
`(when *load-documentation-database?* (setf (documentation ,method nil) ,attr-remarks))))))))
......
......@@ -24,6 +24,7 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(defpackage :com.genworks.lisp
(:use :common-lisp)
(:nicknames :glisp)
(:export #:*fasl-extension*
#:concatenate-fasls
#:directory-list
......
......@@ -21,6 +21,7 @@
(in-package :geom-base)
#+nil
(defmacro with-format ((format stream-or-file &rest args) &body body)
"Void [Macro]. Used to establish an output format and a stream to which data is to be sent. This
supports a full range of output options such as page dimensions, view transforms, view scales, etc.
......@@ -30,16 +31,83 @@ supports a full range of output options such as page dimensions, view transforms
(gdl::with-format (pdf \"/tmp/box.pdf\" :view-transform (getf *standard-views* :trimetric))
(write-the-object (make-instance 'box :length 100 :width 100 :height 100) cad-output))
</pre>"
(let ((flag (gensym)))
(let ((external-format (getf args :external-format))
(args (remove-plist-keys args (list :external-format))))
`(let ((*%format%* (make-instance ',format ,@args)))
(let ((*stream* (if (or (stringp ,stream-or-file) (pathnamep ,stream-or-file))
(open ,stream-or-file :if-does-not-exist :create
:if-exists :supersede :direction :output
:external-format ,(or external-format :default)
#+nil ,(or external-format
#+mswindows
(excl:crlf-base-ef :1252)
#-mswindows
:default))
,stream-or-file))
(,flag t))
(unwind-protect
(progn (multiple-value-prog1
,(case format
(pdf `(pdf:with-document()
(pdf:with-page (:bounds (make-array 4 :initial-contents
(list 0 0 (format-slot page-width)
(format-slot page-length))))
(with-format-slots (page-width page-length background-color)
(setq background-color (coerce (lookup-color background-color
:ground :background) 'list))
(pdf:with-saved-state
(apply #'pdf:set-rgb-stroke (coerce background-color 'list))
(apply #'pdf:set-rgb-fill (coerce background-color 'list))
(pdf:move-to 0 0)
(pdf:line-to page-width 0)
(pdf:line-to page-width page-length) (pdf:line-to 0 page-length)
(pdf:line-to 0 0) (pdf:fill-and-stroke)))
(with-format-slots (page-width page-length)
(pdf:translate (half page-width) (half page-length)))
,@body)
(when *stream* (pdf:write-document *stream*))))
(pdf-multipage `(pdf:with-document() ,@body (when *stream* (pdf:write-document *stream*))))
;;
;; FLAG -- consider having default
;; initialize-output and finalize-output
;; methods instead of these special
;; cases. Special case is only really
;; needed when we need to wrap things like
;; in PDF.
;;
(dxf `(progn (write-string *dxf-header* *stream*)
,@body
(write-string *dxf-footer* *stream*)))
(otherwise `(progn (write-env (initialize-output) )
,@body
(write-env (finalize-output)))))
(setq ,flag nil)))
(when (and (or (stringp ,stream-or-file) (pathnamep ,stream-or-file)) (streamp *stream*))
(close *stream* :abort ,flag))) nil)))))
(defmacro with-format ((format stream-or-file &rest args) &body body)
"Void [Macro]. Used to establish an output format and a stream to which data is to be sent. This
supports a full range of output options such as page dimensions, view transforms, view scales, etc.
:example
<pre>
(gdl::with-format (pdf \"/tmp/box.pdf\" :view-transform (getf *standard-views* :trimetric))
(write-the-object (make-instance 'box :length 100 :width 100 :height 100) cad-output))
</pre>"
(let ((flag (gensym)))
(let (;;(external-format (getf args :external-format))
(args (remove-plist-keys args (list :external-format))))
`(let ((*%format%* (make-instance ',format ,@args)))
(let ((*stream* (if (or (stringp ,stream-or-file) (pathnamep ,stream-or-file))
`(let ((*%format%* (make-instance ',format ,@args))
(file? (or (stringp ,stream-or-file) (pathnamep ,stream-or-file))))
(let ((*stream* (if file?
(open ,stream-or-file :if-does-not-exist :create
:if-exists :supersede :direction :output
:element-type '(unsigned-byte 8)
;;:external-format ,(or external-format :default)
)
,stream-or-file))
......@@ -48,37 +116,49 @@ supports a full range of output options such as page dimensions, view transforms
(unwind-protect
(progn (multiple-value-prog1
,(case format
(pdf `(pdf:with-document()
(pdf:with-page (:bounds (make-array 4 :initial-contents
(list 0 0 (format-slot page-width)
(format-slot page-length))))
(with-format-slots (page-width page-length background-color)
(setq background-color (coerce (lookup-color background-color
:ground :background) 'list))
(pdf:with-saved-state
(apply #'pdf:set-rgb-stroke (coerce background-color 'list))
(apply #'pdf:set-rgb-fill (coerce background-color 'list))
(pdf:move-to 0 0)
(pdf:line-to page-width 0)
(pdf:line-to page-width page-length) (pdf:line-to 0 page-length)
(pdf:line-to 0 0) (pdf:fill-and-stroke)))
(with-format-slots (page-width page-length)
(pdf:translate (half page-width) (half page-length)))
,@body)
(when *stream* (pdf:write-document *stream*))))
(pdf `(let ((path (glisp:temporary-file)))
(pdf:with-document()
(pdf:with-page (:bounds (make-array 4 :initial-contents
(list 0 0 (format-slot page-width)
(format-slot page-length))))
(with-format-slots (page-width page-length background-color)
(setq background-color (coerce (lookup-color background-color
:ground :background) 'list))
(pdf:with-saved-state
(apply #'pdf:set-rgb-stroke (coerce background-color 'list))
(apply #'pdf:set-rgb-fill (coerce background-color 'list))
(pdf:move-to 0 0)
(pdf:line-to page-width 0)
(pdf:line-to page-width page-length) (pdf:line-to 0 page-length)
(pdf:line-to 0 0) (pdf:fill-and-stroke)))
(with-format-slots (page-width page-length)
(pdf:translate (half page-width) (half page-length)))
,@body)
(pdf:write-document (if file? ,stream-or-file path)))
(when (and *stream* (not file?))
(with-open-file (in path
:element-type '(unsigned-byte 8))
(do ((val (read-byte in nil nil) (read-byte in nil nil)))
((null val))
(write-byte val *stream*))))
(when (probe-file path) (delete-file path))))
;;
;; FLAG -- update multipage to match pdf case behavior
;;
(pdf-multipage `(let ((path (glisp:temporary-file)))
(with-open-file (out path :direction :output
:if-exists :supersede
:if-does-not-exist :create)
(pdf:with-document() ,@body
(pdf:write-document out)))
(when *stream*
(pdf:with-document() ,@body
(pdf:write-document (if file? ,stream-or-file path)))
(when (and *stream* (not file?))
(with-open-file (in path :element-type '(unsigned-byte 8))
(do ((val (read-byte in nil nil) (read-byte in nil nil)))
((null val))
(write-byte val *stream*))))
(delete-file path)))
(when (probe-file path) (delete-file path))))
#+nil
......
......@@ -3,6 +3,7 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(defpackage :com.genworks.lisp
(:use :common-lisp)
(:nicknames :glisp)
(:export #:get-pid
#:run-gs
#:run-shell-command
......
......@@ -102,6 +102,7 @@
#:quaternion-to-rotation
#:quaternion-to-matrix
#:matrix-to-quaternion
#:matrix-to-rotation
#:normalize-quaternion
#:degrees-to-radians
#:acosd
......@@ -132,6 +133,7 @@
#:global-filleted-polygon-projection
#:global-filleted-polyline
#:global-polygon-projection
#:ifs-output-mixin
#:global-polyline
#:graph
#:l-line
......
......@@ -82,6 +82,8 @@
(glisp:define-constant +nominal-origin+ (make-point 0 0 0))
(glisp:define-constant +half-sqrt-2+ (half (sqrt 2.0)))
(defparameter *standard-face-hts* (make-hash-table :test #'equalp))
......@@ -168,7 +170,7 @@ the value of this parameter at your own risk.")
(glisp:define-constant +top-vector+ (make-vector 0 0 1))
(defparameter +lh-identity-matrix+ #2A((-1.0 0.0 0.0)(0.0 1.0 0.0)(0.0 0.0 1.0)))
(defparameter +lh-identity-matrix+ #2A((1.0 0.0 0.0)(0.0 -1.0 0.0)(0.0 0.0 1.0)))
(defun initialize-geom-base (&key edition)
......
......@@ -1203,6 +1203,64 @@ that axis.
(defun matrix-to-rotation (matrix)
(when matrix
(if (and (zerop (- (aref matrix 0 1) (aref matrix 1 0)))
(zerop (- (aref matrix 0 2) (aref matrix 2 0)))
(zerop (- (aref matrix 1 2) (aref matrix 2 1))))
;;
;; have singularity
;;
(if (and (zerop (+ (aref matrix 0 1) (aref matrix 1 0)))
(zerop (+ (aref matrix 0 2) (aref matrix 2 0)))
(zerop (+ (aref matrix 1 2) (aref matrix 2 1)))
(zerop (+ (aref matrix 0 0) (aref matrix 1 1) (aref matrix 2 2) -3)))
;;
;; have identity matrix
;;
(make-vector 1 0 0 0)
;;
;; have 180-degree rotation singularity
;;
(let ((angle pi)
x y z
(xx (half (+ (aref matrix 0 0) 1)))
(yy (half (+ (aref matrix 1 1) 1)))
(zz (half (+ (aref matrix 2 2) 1)))
(xy (/ (+ (aref matrix 0 1) (aref matrix 1 0)) 4))
(xz (/ (+ (aref matrix 0 2) (aref matrix 2 0)) 4))
(yz (/ (+ (aref matrix 1 2) (aref matrix 2 1)) 4)))
(cond ((and (> xx yy) (> xx zz))
(if (zerop xx)
(setq x 0.0 y +half-sqrt-2+ z +half-sqrt-2+)
(setq x (sqrt xx)
y (/ xy x)
z (/ xz x))))
((> yy zz)
(if (zerop yy)
(setq x +half-sqrt-2+ y 0.0 z +half-sqrt-2+)
(setq y (sqrt yy) x (div xy y) z (div yz y))))
(t
(if (zerop zz)
(setq x +half-sqrt-2+ y +half-sqrt-2+ z 0.0)
(setq z (sqrt zz) x (/ xz z) y (/ yz z)))))
(make-vector x y z angle)))
(let* ((angle (acos (half (+ (aref matrix 0 0)
(aref matrix 1 1)
(aref matrix 2 2)