Commit 1fbfaa6a authored by Dave Cooper's avatar Dave Cooper

fixed cl-lite asd file generating glitch with defsystem-depends-on. Started…

fixed cl-lite asd file generating glitch with defsystem-depends-on. Started adding new cases to line-and-arc-constraints.
parent 23764c1d
......@@ -308,12 +308,14 @@ Defaults to nil (i.e. we assume we are loading into a clean system and need all
(if (stringp sexpr)
(format nil "%%remove%%~a%%remove%%" sexpr) sexpr)))
(asdf-defsystem-depends-on (let ((sexpr (glisp:sexpr-from-file
(merge-pathnames (make-pathname :name "defsystem-depends-on"
:type "isc")
(the ppathname)))))
(if (stringp sexpr) sexpr (format nil "\"~s\"" sexpr))))
(asdf-defsystem-depends-on
(let ((sexpr (glisp:sexpr-from-file (merge-pathnames (make-pathname :name "defsystem-depends-on"
:type "isc")
(the ppathname)))))
(if (and sexpr (not (stringp sexpr)))
(error "defsystem-depends-on.isc should be either nil or a string containing the expression
to go inside the actual list form in the asdf file. It came in as ~s instead.~%" sexpr)
sexpr)))
(additional-asd-code (let ((asd-code-file
......@@ -356,36 +358,13 @@ Defaults to nil (i.e. we assume we are loading into a clean system and need all
:version ,(the version)
:depends-on ,(the asdf-depends-on)
,(format nil "%%remove%%#-asdf-unicode :defsystem-depends-on #-asdf-unicode ~a%%remove%%"
(format nil "(:asdf-encodings~a)" (if (read-safe-string (read-safe-string (the asdf-defsystem-depends-on)))
(string-append " "
;;(subseq (the asdf-defsystem-depends-on) 1 (1- (length (the asdf-defsystem-depends-on))))
(format nil "~{~s~^ ~}"
(read-safe-string
(read-safe-string (the asdf-defsystem-depends-on)))))
"")))
;;,(format nil "%%remove%%#+asdf-unicode :defsystem-depends-on #+asdf-unicode ~a%%remove%%" (the asdf-defsystem-depends-on))
,(format nil "%%remove%%#+asdf-unicode :defsystem-depends-on #+asdf-unicode ~a%%remove%%"
(format nil "(~a)" (if (read-safe-string (read-safe-string (the asdf-defsystem-depends-on)))
(string-append " "
;;(subseq (the asdf-defsystem-depends-on) 1 (1- (length (the asdf-defsystem-depends-on))))
(format nil "~{~s~^ ~}"
(read-safe-string
(read-safe-string (the asdf-defsystem-depends-on)))))
"")))
#+nil
(format nil "(:asdf-encodings~a~a)"
(if (the asdf-defsystem-depends-on) " " "")
(or (the asdf-defsystem-depends-on) "")))
,(format nil "%%remove%%#+asdf-unicode :defsystem-depends-on #+asdf-unicode ~a%%remove%%"
(subseq (the asdf-defsystem-depends-on) 1 (1- (length (the asdf-defsystem-depends-on))))
"")
(format nil "(~a)" (or (the asdf-defsystem-depends-on) "")))
"%%remove%%#+asdf-encodings :encoding #+asdf-encodings :utf-8%%remove%%"
;;
;; FLAG -- maybe can get rid of binaries and need to call (the compile-and-load)
;;
......
......@@ -236,12 +236,23 @@
(eql (first second-tangent) :arc-geometry) radius)))
:tangent-arc-tangent-line-radius)
((let ((keys (plist-keys (the arc-constraints))))
(and (= (length keys) 3) (= (count :through-point keys) 2) (= (count :tangent-to keys) 1)))
:tangent-to-through-two-points)
((equalp (plist-keys (the arc-constraints)) '(:through-point :through-point :through-point))
:through-three-points)
(t (error "Constrained-arc --- constraint configuration is not yet supported")))))
:hidden-objects
((constraint-object :type (ecase (the constraint-type)
(:tangent-arc-tangent-line-radius
'arc-constraints-tangent-arc-tangent-line-radius))
'arc-constraints-tangent-arc-tangent-line-radius)
(:through-three-points
'arc-constraints-through-three-points)
(:tangent-to-through-two-points
'arc-constraint-tangent-to-through-two-points))
:pass-down (first-tangent-index)
:constraints (the arc-constraints)))
......@@ -269,7 +280,52 @@ and it automatically trims the result to each point of tangency")
(end-angle (max (the angle-0) (the angle-1)))))
(define-object arc-constraint-tangent-to-through-two-points (base-object)
:input-slots (constraints first-tangent-index) ;; first-tangent-index is ignored for this case.
:computed-slots ((point-a (getf (the constraints) :through-point))
(point-b (getf (reverse-plist (the constraints)) :through-point))
(tangent-to (getf (the constraints) :tangent-to))
(tangent-to-line (getf (the tangent-to) :line)) ;; FLAG -- add arc/circle case.
(tangent-to-side-vector (getf (the tangent-to) :side-vector)))
)
(define-object arc-constraints-through-three-points (base-object)
:input-slots (constraints first-tangent-index) ;; first-tangent-index is ignored for this case.
:computed-slots ((point-a (getf (the constraints) :through-point))
(point-b (getf (rest (rest (the constraints))) :through-point))
(point-c (getf (rest (rest (rest (rest (the constraints))))) :through-point))
(a-b-length (3d-distance (the point-a) (the point-b)))
(a-b-bisector-start (inter-circle-circle (the point-a) (* 5/8 (the a-b-length))
(the point-b) (* 5/8 (the a-b-length)) t))
(a-b-bisector-end (inter-circle-circle (the point-a) (* 5/8 (the a-b-length))
(the point-b) (* 5/8 (the a-b-length)) nil))
(b-c-length (3d-distance (the point-b) (the point-c)))
(b-c-bisector-start (inter-circle-circle (the point-a) (* 5/8 (the b-c-length))
(the point-b) (* 5/8 (the b-c-length)) t))
(b-c-bisector-end (inter-circle-circle (the point-a) (* 5/8 (the b-c-length))
(the point-b) (* 5/8 (the b-c-length)) nil))
(center (inter-line-line (the a-b-bisector-start)
(subtract-vectors (the a-b-bisector-end) (the a-b-bisector-start))
(the b-c-bisector-start)
(subtract-vectors (the b-c-bisector-end) (the b-c-bisector-start))))
(radius (3d-distance (the center) (the point-a)))))
(define-object arc-constraints-tangent-arc-tangent-line-radius (base-object)
:input-slots (constraints first-tangent-index)
......
"(#-(or allegro ccl sbcl) :acl-compat #+(or ccl sbcl) :zacl)"
\ No newline at end of file
"#-(or allegro ccl sbcl) :acl-compat #+(or ccl sbcl) :zacl"
\ No newline at end of file
"(:base :uiop :cl-typesetting :cl-ppcre :cl-who #-allegro :cl-base64 #-allegro :babel :zacl)"
"(:base :uiop :cl-typesetting :cl-ppcre :cl-who #-allegro :cl-base64 #-allegro :babel #-allegro :zacl)"
......@@ -4,12 +4,10 @@
"The Gendl® Common Lisp Portability" :author
"Genworks International" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20170524" :depends-on
:version "20170802" :depends-on
(:base :uiop :cl-typesetting :cl-ppcre :cl-who #-allegro :cl-base64 #-allegro :babel #-allegro :zacl)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings #-(or allegro ccl sbcl) :acl-compat
#+(or ccl sbcl) :zacl)
#+asdf-unicode :defsystem-depends-on #+asdf-unicode (#-(or allegro ccl sbcl) :acl-compat
#+(or ccl sbcl) :zacl)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings #-(or allegro ccl sbcl) :acl-compat #+(or ccl sbcl) :zacl)
#+asdf-unicode :defsystem-depends-on #+asdf-unicode (#-(or allegro ccl sbcl) :acl-compat #+(or ccl sbcl) :zacl)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:file "source/presets") (:file "source/parameters")
......
......@@ -4,11 +4,10 @@
"The Gendl® Generative Web Language (GWL)" :author
"Dave Cooper, Genworks International" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20170524" :depends-on
(:bordeaux-threads ;;:drakma
:glisp #+zacl :aserve #-zacl :paserve :yason)
:version "20170802" :depends-on
(:bordeaux-threads :drakma :glisp #+zacl :aserve #-zacl :paserve :yason)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-unicode :defsystem-depends-on #+asdf-unicode nil
#+asdf-unicode :defsystem-depends-on #+asdf-unicode ()
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:file "source/package") (:file "source/with-all-servers")
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment