Skip to content
GitLab
Commit 7a5fda9c authored by CD's avatar CD
Browse files

Some ACT-R7 related updates

parent 14364076
Hide whitespace changes
Inline Side-by-side
commands/conflict-tree.lisp 100644 → 100755
View file @ 7a5fda9c
File mode changed from 100644 to 100755
commands/dm-commands.lisp 100644 → 100755
View file @ 7a5fda9c
......@@ -282,6 +282,9 @@
;;; : * Fixed a couple typos from the previous update.
;;; 2018.12.17 Dan
;;; : * The remote whynot-dm wasn't using the external version.
;;; 2019.04.04 Dan
;;; : * Cache the result of chunk-spec-slots in the retrieval
;;; : request since that's costly don't want to do it twice.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; General Docs:
......@@ -1510,58 +1513,59 @@
(print-warning x))
(return-from simulate-retrieval-request-plus-seed-fct)))
(when (member :recently-retrieved (chunk-spec-slots request))
(let ((recent (chunk-spec-slot-spec request :recently-retrieved)))
(cond ((> (length recent) 1)
(invalid '("Invalid retrieval request." ":recently-retrieved parameter used more than once.")))
((not (or (eq '- (caar recent)) (eq '= (caar recent))))
(invalid '("Invalid retrieval request." ":recently-retrieved parameter's modifier can only be = or -.")))
((not (or (eq t (third (car recent)))
(eq nil (third (car recent)))
(and (eq 'reset (third (car recent)))
(eq '= (caar recent)))))
(invalid '("Invalid retrieval request." ":recently-retrieved parameter's value can only be t, nil, or reset.")))
(t ;; it's a valid value for recently-retrieved
(if (eq 'reset (third (car recent)))
(bt:with-lock-held ((dm-state-lock dm))
(setf (dm-finsts dm) nil))
(let ((requested-slots (chunk-spec-slots request)))
(when (member :recently-retrieved requested-slots)
(let ((recent (chunk-spec-slot-spec request :recently-retrieved)))
(cond ((> (length recent) 1)
(invalid '("Invalid retrieval request." ":recently-retrieved parameter used more than once.")))
((not (or (eq '- (caar recent)) (eq '= (caar recent))))
(invalid '("Invalid retrieval request." ":recently-retrieved parameter's modifier can only be = or -.")))
((not (or (eq t (third (car recent)))
(eq nil (third (car recent)))
(and (eq 'reset (third (car recent)))
(eq '= (caar recent)))))
(invalid '("Invalid retrieval request." ":recently-retrieved parameter's value can only be t, nil, or reset.")))
(t ;; it's a valid value for recently-retrieved
(let ((finsts (remove-old-dm-finsts dm)))
(if (eq 'reset (third (car recent)))
(bt:with-lock-held ((dm-state-lock dm))
(setf (dm-finsts dm) nil))
(cond ((or (and (eq t (third (car recent))) ;; = request t
(eq (caar recent) '=))
(and (null (third (car recent))) ;; - request nil
(eq (caar recent) '-)))
;; only those chunks marked are available
(setf chunk-list (intersection (mapcar 'car finsts) chunk-list))
(command-output "Only recently retrieved chunks: ~s" chunk-list))
(t
(command-output "Removing recently retrieved chunks:")
(setf chunk-list
(remove-if (lambda (x)
(when (member x finsts :key 'car :test 'eq-chunks-fct)
(command-output "~s" x)
t))
chunk-list))))))))))
(when (member :mp-value (chunk-spec-slots request))
(let ((mp-value (chunk-spec-slot-spec request :mp-value)))
(cond ((> (length mp-value) 1)
(invalid '("Invalid retrieval request." ":mp-value parameter used more than once.")))
((not (eq '= (caar mp-value)))
(invalid '("Invalid retrieval request." ":mp-value parameter's modifier can only be =.")))
((not (numornil (third (car mp-value))))
(invalid '("Invalid retrieval request." ":mp-value parameter's value can only be nil or a number.")))
(t ;; it's a valid request
(setf mp (third (car mp-value)))))))
(let ((finsts (remove-old-dm-finsts dm)))
(cond ((or (and (eq t (third (car recent))) ;; = request t
(eq (caar recent) '=))
(and (null (third (car recent))) ;; - request nil
(eq (caar recent) '-)))
;; only those chunks marked are available
(setf chunk-list (intersection (mapcar 'car finsts) chunk-list))
(command-output "Only recently retrieved chunks: ~s" chunk-list))
(t
(command-output "Removing recently retrieved chunks:")
(setf chunk-list
(remove-if (lambda (x)
(when (member x finsts :key 'car :test 'eq-chunks-fct)
(command-output "~s" x)
t))
chunk-list))))))))))
(when (member :mp-value requested-slots)
(let ((mp-value (chunk-spec-slot-spec request :mp-value)))
(cond ((> (length mp-value) 1)
(invalid '("Invalid retrieval request." ":mp-value parameter used more than once.")))
((not (eq '= (caar mp-value)))
(invalid '("Invalid retrieval request." ":mp-value parameter's modifier can only be =.")))
((not (numornil (third (car mp-value))))
(invalid '("Invalid retrieval request." ":mp-value parameter's value can only be nil or a number.")))
(t ;; it's a valid request
(setf mp (third (car mp-value))))))))
......
commands/p-star-cmd.lisp 100644 → 100755
View file @ 7a5fda9c
File mode changed from 100644 to 100755
commands/procedural-cmds.lisp 100644 → 100755
View file @ 7a5fda9c
File mode changed from 100644 to 100755
core-modules/audio.lisp 100644 → 100755
View file @ 7a5fda9c
File mode changed from 100644 to 100755
core-modules/core-loader.lisp 100644 → 100755
View file @ 7a5fda9c
File mode changed from 100644 to 100755
core-modules/declarative-memory.lisp 100644 → 100755
View file @ 7a5fda9c
......@@ -13,7 +13,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Filename : declarative-memory.lisp
;;; Version : 6.3
;;; Version : 6.4
;;;
;;; Description : Implements the declarative memory module.
;;;
......@@ -466,6 +466,18 @@
;;; : the if since it defaults to 0 thus no need to keep setting
;;; : it there if spreading-activation is off and that's a parameter
;;; : which shouldn't change during a run.
;;; 2019.04.02 Dan
;;; : * Have hash-chunk-contents use the underlying chunk info
;;; : instead of going through the accessors.
;;; 2019.04.04 Dan
;;; : * Cache the result of chunk-spec-slots in the retrieval
;;; : request since that's costly don't want to do it twice.
;;; 2019.04.15 Dan
;;; : * Depend on splice-into-position-des being destructive and
;;; : don't setf with the returned value.
;;; 2019.05.17 Dan [6.4]
;;; : * Allow the sim-hook cache to persist across a reset. Only
;;; : clear the table when a new hook function is set.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; General Docs:
......@@ -670,6 +682,8 @@
cache-sim-hook-results
(sim-hook-cache (make-hash-table :test 'equalp))
last-sim-hook
(chunk-lock (bt:make-lock "dm-chunks")) ;; chunks and chunk-hash-table
(param-lock (bt:make-lock "dm-params")) ;; things through sgp
(state-lock (bt:make-lock "dm-state")) ;; other slots
......@@ -813,14 +827,18 @@
;;; A function for converting a chunk to a list of its info
(defun hash-chunk-contents (chunk)
(cons (chunk-slots-vector chunk)
(mapcar (lambda (x)
(let ((val (fast-chunk-slot-value-fct chunk x)))
(if (stringp val)
(string-upcase val)
(true-chunk-name-fct val))))
(chunk-filled-slots-list-fct chunk t))))
(let ((c (get-chunk chunk)))
(when c
(bt:with-recursive-lock-held ((act-r-chunk-lock c))
(cons (act-r-chunk-filled-slots c)
(mapcar (lambda (x)
(let ((val (cdr x)))
(if (stringp val)
(string-upcase val)
(true-chunk-name-fct val))))
(sort (copy-list (act-r-chunk-slot-value-lists c))
#'< :key (lambda (x) (act-r-slot-index (car x))))))))))
(defun reset-dm-module (dm)
......@@ -851,9 +869,14 @@
(setf (dm-current-trace dm) nil))
(bt:with-lock-held ((dm-param-lock dm))
#| Don't do that at reset
only when a new hook function gets
set so that results persist across a reset for
a given function.
(bt:with-lock-held ((dm-param-lock dm))
;; clear the sim-hook cache
(clrhash (dm-sim-hook-cache dm)))
|#
)
(defun secondary-reset-dm-module (dm)
......@@ -1050,89 +1073,90 @@
(print-warning x))
(return-from start-retrieval)))
(when (member :recently-retrieved (chunk-spec-slots request))
(let ((recent (chunk-spec-slot-spec request :recently-retrieved)))
(cond ((> (length recent) 1)
(invalid :too-many '("Invalid retrieval request." ":recently-retrieved parameter used more than once.")))
((not (or (eq '- (caar recent)) (eq '= (caar recent))))
(invalid :bad-modifier '("Invalid retrieval request." ":recently-retrieved parameter's modifier can only be = or -.")))
((not (or (eq t (third (car recent)))
(eq nil (third (car recent)))
(and (eq 'reset (third (car recent)))
(eq '= (caar recent)))))
(invalid :bad-value '("Invalid retrieval request." ":recently-retrieved parameter's value can only be t, nil, or reset.")))
(t ;; it's a valid value for recently-retrieved
(if (eq 'reset (third (car recent)))
(bt:with-lock-held ((dm-state-lock dm))
(setf (dm-finsts dm) nil))
(let ((finsts (remove-old-dm-finsts dm)))
(let ((requested-slots (chunk-spec-slots request)))
(when (member :recently-retrieved requested-slots)
(let ((recent (chunk-spec-slot-spec request :recently-retrieved)))
(cond ((> (length recent) 1)
(invalid :too-many '("Invalid retrieval request." ":recently-retrieved parameter used more than once.")))
((not (or (eq '- (caar recent)) (eq '= (caar recent))))
(invalid :bad-modifier '("Invalid retrieval request." ":recently-retrieved parameter's modifier can only be = or -.")))
((not (or (eq t (third (car recent)))
(eq nil (third (car recent)))
(and (eq 'reset (third (car recent)))
(eq '= (caar recent)))))
(invalid :bad-value '("Invalid retrieval request." ":recently-retrieved parameter's value can only be t, nil, or reset.")))
(t ;; it's a valid value for recently-retrieved
(cond ((or (and (eq t (third (car recent))) ;; = request t
(eq (caar recent) '=))
(and (null (third (car recent))) ;; - request nil
(eq (caar recent) '-)))
;; only those chunks marked are available
(setf chunk-list (intersection (mapcar 'car finsts) chunk-list))
;; save that info for whynot
(setf (last-request-finst last-request) :marked)
(setf (last-request-finst-chunks last-request) chunk-list)
(when sact
(bt:with-lock-held ((dm-state-lock dm))
(setf (sact-trace-only-recent (dm-current-trace dm)) t)
(setf (sact-trace-recents (dm-current-trace dm)) chunk-list)))
(when (dm-act-level act 'high)
(model-output "Only recently retrieved chunks: ~s" chunk-list)))
(t
;; simply remove the marked items
;; may be "faster" to do this later
;; once the set is trimed elsewise, but
;; for now keep things simple
(unwind-protect
(progn
(when sact
(bt:acquire-lock (dm-state-lock dm))
(setf (sact-trace-remove-recent (dm-current-trace dm)) t))
(when (dm-act-level act 'high)
(model-output "Removing recently retrieved chunks:"))
(setf (last-request-finst last-request) :unmarked)
(setf chunk-list
(remove-if (lambda (x)
(when (member x finsts :key 'car :test 'eq-chunks-fct)
(when sact
(push-last x (sact-trace-recents (dm-current-trace dm))))
(when (dm-act-level act 'high)
(model-output "~s" x))
(push x (last-request-finst-chunks last-request))
t))
chunk-list)))
(if (eq 'reset (third (car recent)))
(bt:with-lock-held ((dm-state-lock dm))
(setf (dm-finsts dm) nil))
(let ((finsts (remove-old-dm-finsts dm)))
(cond ((or (and (eq t (third (car recent))) ;; = request t
(eq (caar recent) '=))
(and (null (third (car recent))) ;; - request nil
(eq (caar recent) '-)))
;; only those chunks marked are available
(setf chunk-list (intersection (mapcar 'car finsts) chunk-list))
;; save that info for whynot
(setf (last-request-finst last-request) :marked)
(setf (last-request-finst-chunks last-request) chunk-list)
(when sact
(bt:release-lock (dm-state-lock dm))))))))))))
(when (member :mp-value (chunk-spec-slots request))
(let ((mp-value (chunk-spec-slot-spec request :mp-value)))
(cond ((> (length mp-value) 1)
(invalid :mp-multi '("Invalid retrieval request." ":mp-value parameter used more than once.")))
((not (eq '= (caar mp-value)))
(invalid :mp-modifier '("Invalid retrieval request." ":mp-value parameter's modifier can only be =.")))
((not (numornil (third (car mp-value))))
(invalid :mp-not-num '("Invalid retrieval request." ":mp-value parameter's value can only be nil or a number.")))
(t ;; it's a valid request
(setf mp (third (car mp-value)))))))
(bt:with-lock-held ((dm-state-lock dm))
(setf (sact-trace-only-recent (dm-current-trace dm)) t)
(setf (sact-trace-recents (dm-current-trace dm)) chunk-list)))
(when (dm-act-level act 'high)
(model-output "Only recently retrieved chunks: ~s" chunk-list)))
(t
;; simply remove the marked items
;; may be "faster" to do this later
;; once the set is trimed elsewise, but
;; for now keep things simple
(unwind-protect
(progn
(when sact
(bt:acquire-lock (dm-state-lock dm))
(setf (sact-trace-remove-recent (dm-current-trace dm)) t))
(when (dm-act-level act 'high)
(model-output "Removing recently retrieved chunks:"))
(setf (last-request-finst last-request) :unmarked)
(setf chunk-list
(remove-if (lambda (x)
(when (member x finsts :key 'car :test 'eq-chunks-fct)
(when sact
(push-last x (sact-trace-recents (dm-current-trace dm))))
(when (dm-act-level act 'high)
(model-output "~s" x))
(push x (last-request-finst-chunks last-request))
t))
chunk-list)))
(when sact
(bt:release-lock (dm-state-lock dm))))))))))))
(when (member :mp-value requested-slots)
(let ((mp-value (chunk-spec-slot-spec request :mp-value)))
(cond ((> (length mp-value) 1)
(invalid :mp-multi '("Invalid retrieval request." ":mp-value parameter used more than once.")))
((not (eq '= (caar mp-value)))
(invalid :mp-modifier '("Invalid retrieval request." ":mp-value parameter's modifier can only be =.")))
((not (numornil (third (car mp-value))))
(invalid :mp-not-num '("Invalid retrieval request." ":mp-value parameter's value can only be nil or a number.")))
(t ;; it's a valid request
(setf mp (third (car mp-value))))))))
(let ((best-val nil)
(best nil)
......@@ -1583,7 +1607,18 @@
(setf (dm-finst-span dm) (safe-seconds->ms (cdr param) 'sgp))
(cdr param))
(:sim-hook (setf (dm-sim-hook dm) (cdr param)))
(:sim-hook
;; If a different sim-hook is set clear the cache
(when (cdr param)
(when (and (dm-last-sim-hook dm)
(cdr param)
(not (equalp (cdr param) (dm-last-sim-hook dm))))
(clrhash (dm-sim-hook-cache dm)))
(setf (dm-last-sim-hook dm) (cdr param)))
(setf (dm-sim-hook dm) (cdr param)))
(:sji-hook (setf (dm-sji-hook dm) (cdr param)))
(:w-hook (setf (dm-w-hook dm) (cdr param)))
......@@ -1637,7 +1672,8 @@
(push (cdr param) (dm-chunk-add-hook dm)))
(setf (dm-chunk-add-hook dm) nil)))
(:nsji (setf (dm-nsji dm) (cdr param)))
(:cache-sim-hook-results (setf (dm-cache-sim-hook-results dm) (cdr param)))))
(:cache-sim-hook-results
(setf (dm-cache-sim-hook-results dm) (cdr param)))))
(t
(case param
......@@ -1923,7 +1959,7 @@
(let ((result nil))
(dolist (x ordering result)
(aif (position-if (lambda (y) (find (car x) (cdr y))) result)
(setf result (splice-into-position-des result it x))
(splice-into-position-des result it x)
(push-last x result)))))
......@@ -2060,7 +2096,7 @@
(define-parameter :cache-sim-hook-results :valid-test 'tornil :default-value nil
:warning "T or nil" :documentation "Whether the results of calling a sim-hook function should be cached to avoid future calls to the hook function"))
:version "6.3"
:version "6.4"
:documentation "The declarative memory module stores chunks from the buffers for retrieval"
;; The creation function returns a new dm structure
......
core-modules/goal.lisp 100644 → 100755
View file @ 7a5fda9c
File mode changed from 100644 to 100755
core-modules/imaginal.lisp 100644 → 100755
View file @ 7a5fda9c
File mode changed from 100644 to 100755
core-modules/motor.lisp 100644 → 100755
View file @ 7a5fda9c
......@@ -404,6 +404,9 @@
;;; : the result which is wrong:
;;; : 1[5]: (DIRECTION= -2.7610862 2.8501358)
;;; : 1[5]: returned NIL
;;; 2019.04.23 Dan
;;; : * Create the chunk-type definition for motor extensions when
;;; : they're added instead of at every reset.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#+:packaged-actr (in-package :act-r)
......@@ -1176,9 +1179,13 @@
(bt:with-lock-held ((requests-table-lock dummy-module))
(if (gethash ct-name (new-requests-table dummy-module))
(print-warning "Request ~s is already an extension of the manual buffer. To redefine you must remove it first with remove-manual-request." ct-name)
(progn
(let ((type-list
(if (listp (first chunk-type))
(append chunk-type (list (list 'cmd ct-name)))
(append (list (list ct-name '(:include motor-command))) (rest chunk-type) (list (list 'cmd ct-name))))))
(setf (gethash ct-name (new-requests-table dummy-module))
(cons (copy-list chunk-type) function-name))
(cons type-list function-name))
t)))))))
(defmacro remove-manual-request (chunk-type)
......@@ -1297,15 +1304,12 @@
;; Define the chunk-types for the specified extensions
(maphash (lambda (name value)
(let* ((chunk-type-list (car value))
(type (chunk-type-fct (if (listp (first chunk-type-list))
(append chunk-type-list `((cmd ,name)))
(append `((,(first chunk-type-list) (:include motor-command))) (rest chunk-type-list) `((cmd ,name)))))))
(let ((type (chunk-type-fct (car value))))
(if type
(unless (chunk-p-fct name)
(define-chunks-fct (list (list name 'isa name)))
(make-chunk-immutable name))
(print-warning "Failed to extend motor capabilities with chunk-type definition: ~s" chunk-type-list))))
(print-warning "Failed to extend motor capabilities with chunk-type definition: ~s" (car value)))))
(bt:with-lock-held ((requests-table-lock instance)) (new-requests-table instance)))
)
......
core-modules/procedural.lisp 100644 → 100755
View file @ 7a5fda9c
......@@ -809,6 +809,15 @@
;;; : slot.
;;; 2019.03.06 Dan
;;; : * Use valid-slot-index instead of valid-slot-name.
;;; 2019.05.03 Dan
;;; : * Can't use the length of (buffers) to set the lookup array
;;; : because if a buffer is removed and added back it'll get a
;;; : new index that's outside that range. Using the new max-
;;; : buffer-index command instead.
;;; 2019.05.16 Dan
;;; : * Fixed production-statement-text for the @ actions because
;;; : it assumed only the old style of '@buffer> chunk' was
;;; : possible.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; General Docs:
......@@ -1093,7 +1102,7 @@
(setf (procedural-delayed-resolution prod) nil)
(setf (procedural-buffer-indices prod) nil)
(setf (procedural-buffer-lookup prod) nil)
(setf (procedural-buffer-lookup-size prod) (length (buffers)))
(setf (procedural-buffer-lookup-size prod) (1+ (max-buffer-index)))
(setf (procedural-last-cr-time prod) nil)
(setf (procedural-search-buffer-table prod) (make-hash-table))
......@@ -2176,7 +2185,14 @@
;; there's only one thing in the definition but leave it flexible...
(format s " ~c~a> ~{~s~^ ~}~%" op target (replace-variables definition bindings))))
(#\@
(format s " @~a> ~s~%" target (replace-variables (car definition) bindings)))
(cond ((null definition)
(format s " @~a>~%" target))
((= (length definition) 1)
(format s " @~a> ~s~%" target (first (replace-variables definition bindings))))
(t
(format s " @~a>~%" target)
(dolist (slot (replace-variables (chunk-spec-slot-spec spec) bindings))
(format s " ~s ~s~%" (spec-slot-name slot) (spec-slot-value slot))))))
(#\!
(format s " !~a! ~{~s~^ ~}~%" target (replace-variables definition bindings)))
(#\+
......
core-modules/speech.lisp 100644 → 100755
View file @ 7a5fda9c
File mode changed from 100644 to 100755
core-modules/vision.lisp 100644 → 100755
View file @ 7a5fda9c
......@@ -1148,6 +1148,21 @@
;;; : given point along the z axis. Both are simplifications to
;;; : avoid having to know head and eye geometry as well as head
;;; : position.
;;; 2019.03.22 Dan
;;; : * Changed add-visicon-features to not use valid-vis-loc-chunk
;;; : since it can do the tests while processing other things and
;;; : save the chunk lookups.
;;; 2019.04.12 Dan
;;; : * Changed set-default-vis-loc-slots to a macro and made a -fct
;;; : and remote command for it, added some safety checks to attend-
;;; : visual-coordinate, and made chunk-to-visual-position return
;;; : just nil for 'bad' chunks.
;;; 2019.04.15 Dan
;;; : * Depend on splice-into-position-des being destructive and
;;; : don't setf with the returned value.
;;; 2019.05.21 Dan
;;; : * When checking to unstuff the vis-loc buffer, don't unstuff
;;; : it if the chunk is being tracked.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
......@@ -1339,17 +1354,25 @@
(fast-chunk-slot-value-fct chunk (first slots))
(fast-chunk-slot-value-fct chunk (second slots))))
(defmacro set-default-vis-loc-slots (x y z)
`(set-default-vis-loc-slots-fct ',x ',y ',z))
(defun set-default-vis-loc-slots (x y z)
(defun set-default-vis-loc-slots-fct (x y z)
(let ((vis-m (get-module :vision)))
(if vis-m
(if (every 'valid-slot-name (list x y z))
(bt:with-lock-held ((vis-loc-lock vis-m)) (setf (vis-loc-slots vis-m) (list x y z)))
(if (or (eq x y) (eq y z) (eq x z))
(print-warning "Duplicate slot names provided for set-default-vis-loc-slots: ~s, ~s, ~s" x y z)
(bt:with-lock-held ((vis-loc-lock vis-m)) (setf (vis-loc-slots vis-m) (list x y z))))
(dolist (name (list x y z))
(unless (valid-slot-name name)
(print-warning "Slot ~s is not valid in call to set-default-vis-loc-slots." name))))
(print-warning "No vision module available in call to set-default-vis-loc-slots."))))
(defun remote-set-default-vis-loc-slots-fct (x y z)
(set-default-vis-loc-slots-fct (string->name x) (string->name y) (string->name z)))
(add-act-r-command "set-default-vis-loc-slots" 'remote-set-default-vis-loc-slots-fct "Change the names of the default location slots for visual locations. Params: x-slot y-slot z-slot.")
(defmethod set-current-marker ((vis-mod vision-module) marker &optional lof)
(let ((old-clof (clof vis-mod)))
......@@ -1466,7 +1489,7 @@
((zerop pos)
(push chunk (visicon vis-mod)))
(t
(setf (visicon vis-mod) (splice-into-position-des (visicon vis-mod) pos chunk)))))))))
(splice-into-position-des (visicon vis-mod) pos chunk))))))))
......@@ -1698,10 +1721,13 @@
(defun chunk-to-visual-position (chunk)
(when (chunk-p-fct chunk)
(let* ((screen-pos (chunk-slot-value-fct chunk 'screen-pos))
(pos-chunk (and (chunk-p-fct screen-pos) screen-pos)))
(coerce (xyz-loc (or pos-chunk chunk)) 'list))))
(verify-current-model
"chunk-to-visual-position requires a current model."
(when (chunk-p-fct chunk)
(let* ((screen-pos (chunk-slot-value-fct chunk 'screen-pos))
(pos-chunk (and (chunk-p-fct screen-pos) screen-pos))
(loc (coerce (xyz-loc (or pos-chunk chunk)) 'list)))
(when (every 'numberp loc) loc)))))
(defun external-chunk-to-visual-position (chunk)
(chunk-to-visual-position (string->name chunk)))
......@@ -1799,7 +1825,11 @@