Commit 17c1c652 authored by Dave Cooper's avatar Dave Cooper

released 1587p001

parent b0c5e73f
......@@ -4,7 +4,7 @@
"The Gendl™ (legacy) Testing and Tracking Utility, version 2 (using Ajax but pre-gdlAjax, and no JQuery or CSS)"
:author "John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20140416" :depends-on (:gwl-graphics)
:version "20140424" :depends-on (:gwl-graphics)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -4,7 +4,7 @@
"The Gendl™ Web-based Development Environment (tasty)" :author
"John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20140416" :depends-on (:tree :gwl-graphics)
:version "20140424" :depends-on (:tree :gwl-graphics)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -4,7 +4,7 @@
"The Gendl™ Translators to/from XML and potentially other high-level KBE and Knowledge formats"
:author "John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20140416" :depends-on (:gwl)
:version "20140424" :depends-on (:gwl)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -4,7 +4,7 @@
"The Gendl™ Tree component used by Tasty and potentially as a UI component on its own"
:author "John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20140416" :depends-on (:gwl-graphics)
:version "20140424" :depends-on (:gwl-graphics)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -4,7 +4,7 @@
"The Gendl™ Yet Another Definition Documenter (yadd)" :author
"John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20140416" :depends-on
:version "20140424" :depends-on
(:gwl-graphics #-allegro :cl-html-parse)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
......
......@@ -3,7 +3,7 @@
(asdf:defsystem #:base :description
"The Gendl™ Base Core Kernel Engine" :author "John McCarthy"
:license "Affero Gnu Public License (http://www.gnu.org/licenses/)"
:serial t :version "20140416" :depends-on nil
:serial t :version "20140424" :depends-on nil
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
;;
;; Copyright 2002-2011 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(in-package :gdl)
(defmacro defaulting (form &optional default)
"Lisp object. Returns a default value if the reference-chain is not handled.
Note: Defaulting is currently implemented with ignore-errors, so it will return the default value
regardless of whether the reference-chain is actually not handled or throws some other error.
This will be updated in a future GDL release only to return the default if the reference-chain
is actually not handled, and to throw any other errors normally.
:arguments (form \"Reference-chain with the or the-object\"
default \"Lisp expression. Default value to return if reference-chain cannot be handled.\")"
(let ((value (gensym)) (error (gensym)))
`(multiple-value-bind (,value ,error) (ignore-errors ,form)
(cond ((and ,error (typep ,error 'error)
(let ((string (format nil "~a" ,error)))
(or (and (search "attempt to call" string)
(search "gdl-slots::" string))
(search "nor any of its ancestor instances could handle the" string)
(search "which is the root object, could not handle the" string)))) ,default)
((typep ,error 'error) (error ,error))
(t ,value)))))
;;
;; Copyright 2002-2011 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(in-package :gdl)
(defmacro defaulting (form &optional default)
"Lisp object. Returns a default value if the reference-chain is not handled.
:arguments (form \"Reference-chain with the or the-object\"
default \"Lisp expression. Default value to return if reference-chain cannot be handled.\")"
(let ((value (gensym)) (error (gensym)))
`(multiple-value-bind (,value ,error) (ignore-errors ,form)
(cond ((and ,error (typep ,error 'error)
(let ((string (glisp:replace-regexp (format nil "~a" ,error)
(format nil "~%") " ")))
(or (and (search "attempt to call" string)
(search "gdl-slots::" string))
(search "nor any of its ancestor instances could handle the" string)
(search "which is the root object, could not handle the" string)))) ,default)
((typep ,error 'error) (error ,error))
(t ,value)))))
......@@ -23,7 +23,7 @@
;;(defparameter *gendl-version* "1585p002")
;;(defparameter *gendl-version* "1587devo")
(defparameter *gendl-version* "1587p001")
(defparameter *gendl-version* "1587p002")
;;(defparameter *gendl-version* "ql-2013-12")
(defparameter *gendl-patch-level* nil)
......
......@@ -3,7 +3,7 @@
(asdf:defsystem #:cl-lite :description
"The Gendl™ Compile-and-Load Lite Utility" :author "John McCarthy"
:license "Affero Gnu Public License (http://www.gnu.org/licenses/)"
:serial t :version "20140416" :depends-on (:glisp)
:serial t :version "20140424" :depends-on (:glisp)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -3,7 +3,7 @@
(asdf:defsystem #:bus :description
"The Gendl™ Wireframe School Bus Demo" :author "John McCarthy"
:license "Affero Gnu Public License (http://www.gnu.org/licenses/)"
:serial t :version "20140416" :depends-on nil
:serial t :version "20140424" :depends-on nil
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -3,7 +3,7 @@
(asdf:defsystem #:ledger :description
"The Gendl™ Ledger Bookkeeping Demo" :author "John McCarthy"
:license "Affero Gnu Public License (http://www.gnu.org/licenses/)"
:serial t :version "20140416" :depends-on
:serial t :version "20140424" :depends-on
(#-gwl :gwl)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
......
......@@ -4,7 +4,7 @@
"The Gendl™ Simplified Android Robot example " :author
"John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20140416" :depends-on nil
:version "20140424" :depends-on nil
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -4,7 +4,7 @@
"The Gendl™ Wire-World demo and test-case for wireframe tessellation and X3D output"
:author "John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20140416" :depends-on
:version "20140424" :depends-on
(#-gwl-graphics :gwl-graphics)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
......
......@@ -3,7 +3,7 @@
(asdf:defsystem #:examples :description
"The Gendl™ examples Subsystem" :author "John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20140416" :depends-on (:gwl-graphics :surf)
:version "20140424" :depends-on (:gwl-graphics :surf)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -135,6 +135,7 @@
(defun gdl () (interactive) (gendl 'gdl))
(defun agdl8 () (interactive) (gendl 'agdl8))
(defun agdl () (interactive) (gendl 'agdl))
(defun glime () (interactive) (gendl))
(defun gdl-quit () (interactive) (slime-quit-lisp))
......
......@@ -135,7 +135,7 @@ and <tt>nil</tt> are supported. The default is nil"
(:right (translate (lastcar (the leader-path)) :right (the text-gap)))
(:left (translate (lastcar (the leader-path)) :left (+ (the text-gap) (the-child width)))))
:strings (or (ensure-list (the strings)) (ensure-list (the text)))
:pass-down (font outline-shape-type character-size dxf-text-x-scale dxf-size-ratio dxf-font dxf-offset))))
:pass-down (onclick-function font outline-shape-type character-size dxf-text-x-scale dxf-size-ratio dxf-font dxf-offset))))
......
......@@ -359,5 +359,6 @@ and end-point."
(the leader-start)))
(the orientation))
:pass-down (font character-size text-x-scale justification outline-shape-type underline?
dxf-text-x-scale dxf-size-ratio dxf-font dxf-offset))))
dxf-text-x-scale dxf-size-ratio dxf-font dxf-offset
onclick-function))))
......@@ -3,7 +3,7 @@
(asdf:defsystem #:geom-base :description
"The Gendl™ Wireframe Geometry" :author "John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20140416" :depends-on (:glisp)
:version "20140424" :depends-on (:glisp)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -215,6 +215,7 @@ is specified), so it is necessary to explicitly give either start or center for
:text (nth (the-child index) (the string-list))
:pass-down (character-size text-x-scale font underline? width
dxf-text-x-scale dxf-font dxf-offset dxf-size-ratio
onclick-function
)
:start (translate (the start)
:front (* (the-child index)(the leading))
......
......@@ -3,7 +3,7 @@
(asdf:defsystem #:glisp :description
"The Gendl™ Common Lisp Portability" :author "John McCarthy"
:license "Affero Gnu Public License (http://www.gnu.org/licenses/)"
:serial t :version "20140416" :depends-on
:serial t :version "20140424" :depends-on
(:base :uiop :cl-typesetting :cl-ppcre :cl-who #-allegro :cl-base64 #-allegro :babel #-allegro :acl-compat)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
......
......@@ -3,7 +3,7 @@
(asdf:defsystem #:gwl-graphics :description
"The Gendl™ GWL embedded graphics support" :author "John McCarthy"
:license "Affero Gnu Public License (http://www.gnu.org/licenses/)"
:serial t :version "20140416" :depends-on (:geom-base :gwl)
:serial t :version "20140424" :depends-on (:geom-base :gwl)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -283,20 +283,24 @@
(lookup-color (getf display-controls :fill-color) :format :hex))
(the-object object fill-color-hex))))
(when fill (fmt "~a.attr({fill: '~a'});" name fill)))
(let ((line-thickness (getf display-controls :line-thickness)))
(setq line-thickness (when line-thickness (number-round line-thickness 4)))
(when line-thickness
(fmt "~&~a.attr('stroke-width','~a');" name (number-round line-thickness 4)))
(fmt "~&~a.attr('stroke-width','~a');" name line-thickness))
(fmt " ~a.node.onmouseover = function (){~a.attr({'stroke-width': '~a'});};"
name name
(floor (to-single-float (* (or line-thickness 1) 3))))
name name (* (or line-thickness 1.0) 3))
(fmt " ~a.node.onmouseout = function (){~a.attr({'stroke-width': '~a'});};"
name name (to-single-float (or line-thickness 1))))
name name (or line-thickness 1.0)))
;;
;; FLAG -- do something better here than ignore-errors
;;
(cond ((the object onclick-function)
(fmt "~a.node.onclick = function (event) {~a};" name
(the parent parent parent
......@@ -349,7 +353,12 @@
(with-format-slots (view)
(let* ((view-scale (if view (the-object view view-scale-total) 1))
(center (translate (the center) :front (half (half (* 0.7 (the length)))))))
(center (translate (the center) :front (half (half (* 0.7 (the length))))))
(name (base64-encode-safe
(format nil "~s"
(remove :root-object-object
(the root-path))))))
(setq center (if view (the-object view (view-point center)) center))
......@@ -368,7 +377,11 @@
(unless (zerop rotation) ;; FLAG -- rotate in raphael(pdf:rotate rotation)
)
(with-cl-who ()
(fmt "paper.text(~a, ~a, \"~a\").attr({\"font\": \"~2,3fpx Arial\", \"antialias\": \"false\", \"stroke\": \"~a\", \"fill\": \"~a\"});"
(fmt "var ~a;~%" name)
(fmt "~&~a = paper.text(~a, ~a, \"~a\").attr({\"font\": \"~2,3fpx Arial\", \"antialias\": \"false\", \"stroke\": \"~a\", \"fill\": \"~a\"});"
name
(get-x center)
(get-y center)
(the %text-to-draw%)
......@@ -385,7 +398,18 @@
(or (or (when (getf display-controls :fill-color)
(lookup-color (getf display-controls :fill-color) :format :hex))
(the-object object fill-color-hex)) "#000"))))))))))
(the-object object fill-color-hex)) "#000"))
(cond ((and view (the onclick-function))
(fmt "~a.node.onclick = function (event) {~a};" name
(the-object view parent parent
(gdl-ajax-call :function-key :call-onclick-function!
:arguments (list self)))))
((ignore-errors (and (the viewport) (eql (the viewport digitation-mode) :select-object)))
(fmt "~a.node.onclick = function (event) {~a};" name
(the viewport (gdl-ajax-call :function-key :set-object-to-inspect!
:arguments (list self)))))
(t nil))))))))))
(define-lens (raphael point)()
......
......@@ -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 "20140416" :depends-on (:glisp :aserve)
:serial t :version "20140424" :depends-on (:glisp :aserve)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
(in-package :gwl)
(#+allegro
excl:without-redefinition-warnings
#-allegro progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(#+allegro
excl:without-redefinition-warnings
#-allegro progn
(defmacro with-error-handling ((&key (error? nil)
(timeout 2)
(timeout-body
`(warn "Timed Out after ~a Seconds" ,timeout)))
&body body)
"[Macro]. Wraps the <b>body</b> of code with error-trapping and system timeout.
(defmacro with-error-handling ((&key (error? nil)
(timeout 2)
(timeout-body
`(warn "Timed Out after ~a Seconds" ,timeout)))
&body body)
"[Macro]. Wraps the <b>body</b> of code with error-trapping and system timeout.
A warning is given if an error condition occurs with <b>body</b>.
:&key ((timeout 2) \"Timeout in Seconds.\"
......@@ -18,14 +19,14 @@ A warning is given if an error condition occurs with <b>body</b>.
:&rest (body \"Body of code to be wrapped\")"
(if error? `(progn ,@body)
(let ((values (gensym)) (error (gensym)))
(let ((code `(let* ((,values (multiple-value-list (ignore-errors ,@body)))
(,error (second ,values)))
(if (and ,error (typep ,error 'error))
(progn (warn "~a" ,error)
(values nil ,error))
(apply #'values ,values)))))
(if timeout
`(,(glisp:with-timeout-sym) (,timeout ,timeout-body) ,code)
code))))))
(if error? `(progn ,@body)
(let ((values (gensym)) (error (gensym)))
(let ((code `(let* ((,values (multiple-value-list (ignore-errors ,@body)))
(,error (second ,values)))
(if (and ,error (typep ,error 'error))
(progn (warn "~a" ,error)
(values nil ,error))
(apply #'values ,values)))))
(if timeout
`(,(glisp:with-timeout-sym) (,timeout ,timeout-body) ,code)
code)))))))
......@@ -3,7 +3,7 @@
(asdf:defsystem #:regression :description
"The Gendl™ regression Subsystem" :author "John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20140416" :depends-on (:lift :surf :tasty)
:version "20140424" :depends-on (:lift :surf :tasty)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
......@@ -4,7 +4,7 @@
"The Gendl™ NURBS Surface and Solids Geometry Primitives" :author
"John McCarthy" :license
"Affero Gnu Public License (http://www.gnu.org/licenses/)" :serial t
:version "20140416" :depends-on (:geom-base)
:version "20140424" :depends-on (:geom-base)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
......
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