Commit e761fccd authored by Dave Cooper's avatar Dave Cooper

Merge branch 'hotfix/glm'

parents 283720bc de5a7db1
......@@ -210,6 +210,7 @@
(defun load-and-or-start-gendl ()
(setq slime-enable-evaluate-in-emacs t)
(slime-repl)
(insert gdl-startup-string)
(slime-repl-return)
......@@ -333,6 +334,28 @@
(fi:inferior-lisp-newline)
(end-of-buffer)))
(defun timestamp ()
(insert (format-time-string "%Y-%m-%dT%H:%M:%S" (current-time))))
;;
;; See http://pomodorotechnique.com/
;;
(defun pomodoro ()
(timestamp)
(insert (format-time-string ";%Y-%m-%dT%H:%M:%S;"
(time-add (current-time) (seconds-to-time (* 25 60))))))
(global-set-key "\C-t" '(lambda() (interactive) (pomodoro)))
(defun post-pomodoro ()
(insert (format-time-string "%Y-%m-%dT%H:%M:%S"
(time-subtract (current-time) (seconds-to-time (* 25 60)))))
(insert (format-time-string ";%Y-%m-%dT%H:%M:%S;" (current-time))))
(global-set-key "\M-t" '(lambda() (interactive) (post-pomodoro)))
;;
;; Establish input method for I.A.S.T diacritics
;;
......
(in-package :surf)
(defparameter *1588p005-doc*
" Fix the order of the returned u,v point for the point function of uv-iso-curve.")
(define-object uv-iso-curve ()
:documentation (:description "Convenience object to return UV parameter values on surface.")
:input-slots (surface parameter u-or-v)
:functions
(("2D point. The UV surface representation at the given parameter value.
:arguments (parameter \"Number. The parameter value you want.\")"
point
(parameter)
(ecase (the u-or-v)
(:v (make-point (the parameter) parameter))
(:u (make-point parameter (the parameter)))))))
(in-package :gdl)
(defparameter *1588p006-doc*
" Keep the items in internal %version-tree% sorted based on root-path length.")
(define-object-amendment vanilla-mixin* ()
:functions
(("NIL. Restores the value of the given slot to its default, thus ``undoing'' any forcibly set value
in the slot. Any dependent slots in the tree will respond accordingly when they are next demanded.
Note that the slot must be specified as a keyword symbol (i.e. prepended with a colon (``:'')),
otherwise it will be evaluated as a variable according to normal Lisp functional evaluation rules.
:arguments (slot \"Keyword Symbol\")
:key (force? \"Boolean. Specify as t if you want to force non-settable slots to recompute (e.g.
reading from databases or external files). Defaults to nil.\")"
restore-slot-default!
(attribute &key (force? *force-restore-slot-default?*))
(when (or force? (eql (the (slot-status attribute)) :set))
(let (*leaf-resets*)
(let ((slot (glisp:intern (symbol-name attribute) :gdl-acc)))
(unless (eq (first (ensure-list (slot-value self slot))) 'gdl-rule::%unbound%)
(unbind-dependent-slots self slot)
(setf (slot-value self slot)
(if *remember-previous-slot-values?*
(list 'gdl-rule::%unbound% nil nil (first (slot-value self slot)))
'gdl-rule::%unbound%))))
(let ((root (let ((maybe-root (the :root)))
(if (the-object maybe-root root?)
maybe-root
(the-object maybe-root parent))))
;;(root-path (remove :root-object-object (the root-path)))
(root-path (the root-path))
)
;;
;; FLAG -- this pushnew should never be necessary...
;;
(pushnew (list root-path)
(gdl-acc::%version-tree% root) :test #'equalp :key #'(lambda(item) (list (first item))))
(setf (rest (assoc root-path (gdl-acc::%version-tree% root) :test #'equalp))
(remove-plist-key (rest (assoc root-path
(gdl-acc::%version-tree% root) :test #'equalp)) attribute))
(setf (gdl-acc::%version-tree% root)
(sort (gdl-acc::%version-tree% root)
#'(lambda(item1 item2)
(< (length (first item1)) (length (first item2)))))))
(when *eager-setting-enabled?*
(dolist (reset *leaf-resets*)
(the-object (first reset) (evaluate (second reset))))))))
("Void. Writes a file containing the toplevel inputs and modified settable-slots starting from the root of the
current instance. Typically this file can be read back into the system using the <tt>read-snapshot</tt> function.
:&key ((filename \"/tmp/snap.gdl\") \"String or pathname. The target file to be written.\"
(root-paths-to-ignore nil) \"List of root-paths or nil. Any objects with matching root-path will be ignored for the snapshot write.\"
)"
write-snapshot
(&key (filename "/tmp/snap.gdl") (root-paths-to-ignore nil))
(let (*print-level*
(root-object-object? (and (the parent) (the parent root?)
(defaulting (the parent root-object-object))
(eql (the parent root-object-object) self))))
(let ((root (if root-object-object? (the root parent) (the root))))
(setf (gdl-acc::%version-tree% root)
(sort (gdl-acc::%version-tree% root)
#'(lambda(item1 item2)
(< (length (first item1)) (length (first item2))))))
(with-open-file (out filename :direction :output :if-exists :supersede :if-does-not-exist :create)
(print `(in-package ,(make-keyword (package-name *package*))) out)
(mapcar #'(lambda(node)
(let ((root-path (first node)) (value-plist (rest node)))
(unless (or (member root-path root-paths-to-ignore :test #'equalp)
(and root-object-object?
(not (eql (lastcar root-path) :root-object-object))))
(when root-object-object?
(setq root-path (if (consp (rest root-path))
(butlast root-path)
(the type))))
(let ((keys (plist-keys value-plist)) (values (plist-values value-plist)))
(let ((snap (cons root-path
(append (when (atom root-path)
(let (result)
(let* ((toplevel-inputs
(remove-plist-key (the root active-inputs)
:remote-id))
(toplevel-input-keys (plist-keys toplevel-inputs))
(toplevel-input-values (plist-values toplevel-inputs)))
(mapc #'(lambda(key value)
(when (not (member key keys))
(push key result) (push value result)))
toplevel-input-keys toplevel-input-values))
(nreverse result)))
(mapcan #'(lambda(key val)
(let ((expression (readable-expression val self)))
(unless (eql expression :%unreadable%)
(list key expression))))
keys values))))) (print snap out))))))
(or (gdl-acc::%version-tree% root) (list nil))))))
filename)))
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