...
 
Commits (11)
No preview for this file type
Subject 1: 635,
......@@ -43,6 +43,19 @@
;;; : the same (doesn't affect the matching itself).
;;; 2011.04.28 Dan
;;; : * Added some declares to quite compliation warnings.
;;; 2013.10.18 Dan
;;; : * Added a few more stats to conflict-tree-stats.
;;; 2014.03.17 Dan [2.0]
;;; : * Changed the query-buffer call to be consistent with the new
;;; : internal code.
;;; 2014.04.03 Dan
;;; : * Ignore the isa tests for now and instead use all the implicit
;;; : tests which were being ignored previously...
;;; 2014.05.19 Dan
;;; : * To avoid warnings at load time commenting out the code from
;;; : the isa-node processing methods.
;;; 2014.05.30 Dan
;;; : * Also commented out the isa condition in split-productions-with-condition.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; General Docs:
......@@ -83,9 +96,12 @@
;;; are valid
;;; :sets - the number of different sets of productions found at in the
;;; non-empty leaf nodes
;;; :average-set - the mean size of non-empty sets
;;; :largest-set - the size of the largest set
;;;
;;; > (conflict-tree-stats )
;;; ((:DEPTH . 24) (:MIN-DEPTH . 3) (:TOTAL-NODES . 4670) (:TERMINAL . 3422) (:NON-EMPTY . 3373) (:SETS . 1073))
;;; ((:DEPTH . 24) (:MIN-DEPTH . 3) (:TOTAL-NODES . 4670) (:TERMINAL . 3422) (:NON-EMPTY . 3373) (:SETS . 1073)
;;; (:AVERAGE-SET . 4.746098) (:LARGEST-SET . 187))
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
......@@ -164,15 +180,18 @@
(root-node-child node))
(defmethod select-child ((node isa-node) prod)
(declare (ignorable node prod))
#|
(let ((type (aif (cr-buffer-read prod (isa-node-buffer node) (isa-node-buffer-index node))
(chunk-chunk-type-fct it)
nil)))
(if (and type (chunk-type-subtype-p-fct type (isa-node-value node)))
(isa-node-true node)
(isa-node-false node))))
|#)
(defmethod select-child ((node test-slot-node) prod)
(let ((buffer-val (cr-buffer-slot-read prod (test-slot-node-buffer node) (test-slot-node-buffer-index node) (test-slot-node-slot-index node))))
(let ((buffer-val (cr-buffer-slot-read prod (test-slot-node-buffer node) (test-slot-node-buffer-index node) (test-slot-node-slot-index node) (test-slot-node-slot node))))
(if (funcall (test-slot-node-test node) buffer-val (test-slot-node-value node))
(test-slot-node-true node)
(test-slot-node-false node))))
......@@ -180,12 +199,12 @@
(defmethod select-child ((node query-node) prod)
(declare (ignore prod))
(if (query-buffer (query-node-buffer node) (list (cons (query-node-query node) (query-node-value node))))
(if (query-buffer (query-node-buffer node) (list (query-node-query node) (query-node-value node)))
(binary-test-node-true node)
(binary-test-node-false node)))
(defmethod select-child ((node slot-node) prod)
(let ((buffer-val (cr-buffer-slot-read prod (slot-node-buffer node) (slot-node-buffer-index node) (slot-node-slot-index node))))
(let ((buffer-val (cr-buffer-slot-read prod (slot-node-buffer node) (slot-node-buffer-index node) (slot-node-slot-index node) (slot-node-slot node))))
(aif (gethash buffer-val (slot-node-children node))
it
(gethash :other (slot-node-children node)))))
......@@ -233,10 +252,14 @@
(defun conflict-tree-stats ()
(setf *tree-data* nil)
(mapcar #'cons '(:depth :min-depth :total-nodes :terminal :non-empty :sets)
(mapcar #'cons '(:depth :min-depth :total-nodes :terminal :non-empty :sets :average-set :largest-set)
(append (multiple-value-list (get-tree-stats (procedural-conflict-tree (get-module procedural))))
(list (length *tree-data*)) (list (length (remove nil *tree-data*)))
(list (length (remove-duplicates *tree-data* :test 'equalp))))))
(list (length (remove-duplicates *tree-data* :test 'equalp)))
(list (let ((nodes (remove nil *tree-data*)))
(unless (null nodes)
(* 1.0 (/ (reduce '+ (mapcar 'length nodes)) (length nodes))))))
(list (reduce 'max (mapcar 'length *tree-data*))))))
(defmethod get-tree-stats ((node binary-test-node))
(let ((max-depth 0)
......@@ -347,8 +370,8 @@
(defmethod add-to-tree ((node isa-node) conditions production)
(aif (find (isa-node-condition node) conditions :test 'cr-condition-equal)
(declare (ignorable node conditions production))
#|(aif (find (isa-node-condition node) conditions :test 'cr-condition-equal)
;; then it's a true test
(add-to-tree (isa-node-true node) (remove it conditions) production)
;; check if there's some other test of the type on this buffer
......@@ -367,7 +390,9 @@
;; otherwise add it to both branches - if there's any possibility it could match
(progn
(add-to-tree (isa-node-true node) conditions production)
(add-to-tree (isa-node-false node) conditions production))))))
(add-to-tree (isa-node-false node) conditions production)))))
|#
)
(defmethod add-to-tree ((node binary-test-node) conditions production) ;; query and test-slot
......@@ -543,7 +568,7 @@
(push-last x (second y)))))
results))
((eq 'isa (cr-condition-type c))
(let ((results (list (list t nil) (list nil nil))))
#|(let ((results (list (list t nil) (list nil nil))))
(dolist (x conditions)
(aif (find c (append (second x) (third x)) :test 'cr-condition-equal)
;; then it's a true test
......@@ -560,7 +585,7 @@
(progn
(push-last x (second (first results)))
(push-last x (second (second results))))))))
results))
results)|#)
(t ; slot-test and queries are easier
......@@ -597,6 +622,7 @@
(all-same t)
(last nil))
(dolist (x valid-conditions)
(unless (eq (cr-condition-type x) 'isa)
(multiple-value-bind (v g) (split-productions-with-condition x conditions)
;(format t "~S: ~S~%" v x)
......@@ -610,12 +636,12 @@
(> v val))
(setf val v)
(setf groups g)
(setf best x))))
(setf best x)))))
; (format t "Best(~3s): ~S ~S ~%~%" all-same val best)
; (format t "Best(~3s): ~S ~S ~%~%" all-same val best)
(if (or (and negative (minusp val) (> negative 3)) ;; Only make a few negative splits
(if (or (and negative (<= val 0.0) (> negative 3)) ;; Only make a few negative or zero splits
(and all-same (<= val 0.0))) ;; doesn't seem like any improvements left
(make-leaf-node :parent parent :branch branch :valid (mapcar #'first conditions))
......@@ -657,18 +683,18 @@
(if (binary-test-node-p new-node)
(progn
(setf (binary-test-node-true new-node)
(build-tree-from-productions t new-node (second (first groups)) (if (minusp val)
(build-tree-from-productions t new-node (second (first groups)) (if (<= val 0.0)
(if negative (1+ negative) 0)
0)))
(setf (binary-test-node-false new-node) (build-tree-from-productions nil new-node (second (second groups)) (if (minusp val)
(setf (binary-test-node-false new-node) (build-tree-from-productions nil new-node (second (second groups)) (if (<= val 0.0)
(if negative (1+ negative) 0)
0))))
(progn
(dolist (x groups)
(setf (gethash (first x) (wide-test-node-children new-node))
(build-tree-from-productions (first x) new-node (second x) (if (minusp val)
(build-tree-from-productions (first x) new-node (second x) (if (<= val 0.0)
(if negative (1+ negative) 0)
0))))))
new-node))))))
......@@ -698,7 +724,7 @@
(setf (root-node-valid (procedural-conflict-tree procedural)) (mapcar #'production-name (productions-list procedural)))
(setf (root-node-child (procedural-conflict-tree procedural))
(build-tree-from-productions t (procedural-conflict-tree procedural)
(mapcar (lambda (x) (list (production-name x) (copy-list (production-constants x)) (copy-list (production-implicit x))))
(mapcar (lambda (x) (list (production-name x) (append (copy-list (production-constants x)) (copy-list (production-implicit x)))))
(productions-list procedural))
nil))
)
......
This diff is collapsed.
......@@ -13,7 +13,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Filename : p-star-cmd.lisp
;;; Version : 1.2
;;; Version : 2.0
;;;
;;; Description : Functions that work with the procedural module to allow
;;; : definition of productions with bound-variable slot names.
......@@ -225,6 +225,15 @@
;;; 2013.06.04 Dan
;;; : * Fixed valid-variable-chunk-mod-spec to allow static chunks
;;; : to modify any of the possible slots for the type given.
;;; 2014.03.19 Dan [2.0]
;;; : * Start of conversion to chunks without types.
;;; : * Remove define-varaible-chunk-spec-fct and associated functions
;;; : because chunk-specs are now allowed to have variable slot names.
;;; 2014.03.20 Dan
;;; : * Don't really do anything here now, and just keep this around
;;; : mostly for the commnets because p and p* are now the same.
;;; 2015.07.28 Dan
;;; : * Changed the logical to ACT-R-support in the require-compiled.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; General Docs:
......@@ -234,8 +243,8 @@
;;;
;;; Public API:
;;;
;;; p* and p*-fct which work like p and p-fct but allow one to use variables
;;; in the place of slot names as long as those variables get bound elsewhere.
;;; p* and p*-fct which work kust like p and p-fct since those are allowed to
;;; have variables in slot positions now too.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Design Choices:
......@@ -282,7 +291,7 @@
#+(and :clean-actr (not :packaged-actr) :ALLEGRO-IDE) (in-package :cg-user)
#-(or (not :clean-actr) :packaged-actr :ALLEGRO-IDE) (in-package :cl-user)
(require-compiled "PRODUCTION-PARSING" "ACT-R6:support;production-parsing-support")
(require-compiled "PRODUCTION-PARSING" "ACT-R-support:production-parsing-support")
#|
......@@ -329,85 +338,10 @@ test queries, call evals and test remaining slot specs
(defun p*-fct (definition)
(let ((prod (get-module procedural)))
(if (procedural-p prod)
(create-production prod definition t)
(create-production prod definition)
(print-warning "No procedural modulue found cannot create production."))))
(defun define-variable-chunk-spec-fct (specifications-list)
"Allows variables in the slot-name position, but the return value isn't
really a valid chunk-spec for purposes of testing chunks"
(verify-current-mp
"define-variable-chunk-spec-fct called with no current meta-process."
(verify-current-model
"define-variable-chunk-spec-fct called with no current model."
(cond ((null specifications-list)
(print-warning "No specification in call to define-chunk-spec."))
((= (length specifications-list) 1)
(if (get-chunk (car specifications-list))
(chunk-name-to-chunk-spec (car specifications-list))
(print-warning
"define-chunk-spec's 1 parameter doesn't name a chunk: ~S"
specifications-list)))
((not (eq (car specifications-list) 'isa))
(print-warning
"First element to define-chunk-spec isn't the symbol ISA. ~s"
specifications-list))
((not (get-chunk-type (second specifications-list)))
(print-warning
"Second element in define-chunk-spec isn't a chunk-type. ~S"
specifications-list))
(t
(let* ((new-spec (make-act-r-chunk-spec :type (second specifications-list)))
(slots (process-variable-slots-specs (second specifications-list) (cddr specifications-list))))
(unless (eq slots :error)
(setf (act-r-chunk-spec-slots new-spec) slots)
new-spec)))))))
(defun process-variable-slots-specs (chunk-type specs)
(let ((slots nil))
(loop
(when (null specs)
(return slots))
(let ((spec (make-act-r-slot-spec)))
(when (find (car specs) '(= - > < >= <=))
(setf (act-r-slot-spec-modifier spec) (pop specs)))
(when (null specs)
(print-warning
"Invalid specs in call to define-chunk-spec - not enough arguments")
(return :error))
(unless (or (chunk-spec-variable-p (car specs)) ;; let this go through...
(possible-chunk-type-slot chunk-type (car specs))
(keywordp (car specs)))
(print-warning "Invalid slot-name ~S in call to define-chunk-spec."
(car specs))
(return :error))
(setf (act-r-slot-spec-name spec) (pop specs))
(when (null specs)
(print-warning
"Invalid specs in call to define-chunk-spec - not enough arguments")
(return :error))
(setf (act-r-slot-spec-value spec) (pop specs))
(push spec slots)))))
(defun valid-variable-chunk-mod-spec (chunk-type-and-slots modifications-list)
(if (oddp (length modifications-list))
(print-warning "Odd length modifications list.")
(if (procedural-check-p*-mods (get-module procedural))
(do ((slots nil (cons (car s) slots))
(s modifications-list (cddr s)))
((null s)
(and (every #'(lambda (slot)
(or (chunk-spec-variable-p slot)
(and (not (chunk-type-static-p-fct (car chunk-type-and-slots))) (valid-chunk-type-slot (car chunk-type-and-slots) slot))
(and (chunk-type-static-p-fct (car chunk-type-and-slots)) (possible-chunk-type-slot (car chunk-type-and-slots) slot))
(find slot (cdr chunk-type-and-slots))))
slots)
(= (length slots) (length (remove-duplicates slots))))))
t)))
#|
......
......@@ -13,7 +13,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Filename : procedural-cmds.lisp
;;; Version : 1.2
;;; Version : 2.0
;;;
;;; Description : User functions for the procedural module.
;;;
......@@ -305,6 +305,29 @@
;;; 2011.04.28 Dan
;;; : * Added some declaims to avoid compiler warnings about
;;; : undefined functions and removed some unneeded let variables.
;;; 2013.08.05 Dan
;;; : * Clear the hashtables for the style warnings in clear-productions.
;;; 2013.08.09 Dan
;;; : * Added the command decalare-buffer-usage to avoid style
;;; : warnings when chunks are being set through code or otherwise
;;; : not in the initial model definition.
;;; 2013.08.12 Dan
;;; : * Changed declare-buffer-usage to return t/nil.
;;; 2013.10.18 Dan
;;; : * Finally fixed the typo in test-and-perfrom.
;;; 2013.11.14 Dan
;;; : * Changed declare-buffer-usage to also allow suppressing the
;;; : "modified without use" style warnings by adding the slots to
;;; : the procedural-cond-style-usage-table as well.
;;; 2014.04.07 Dan
;;; : * Changed calls to failure-reason-string to not pass procedural.
;;; 2014.05.11 Dan [2.0]
;;; : * Updates to be consistent with the no chunk-type mechanisms.
;;; 2015.07.28 Dan
;;; : * Changed the logical to ACT-R-support in the require-compiled.
;;; 2015.09.11 Dan
;;; : * Add the require for productions here eventhough the procedural
;;; : module will have certainly loaded it already.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; General Docs:
......@@ -334,8 +357,8 @@
(declaim (ftype (function () t) minimum-utility))
(declaim (ftype (function (t) t) production-utility))
(require-compiled "PRODUCTION-PARSING" "ACT-R6:support;production-parsing-support")
(require-compiled "PRODUCTIONS" "ACT-R-support:productions")
(require-compiled "PRODUCTION-PARSING" "ACT-R-support:production-parsing-support")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The user functions mostly from ACT-R 5
......@@ -353,7 +376,7 @@
(if prod
(let ((res nil)
(p (if (null productions)
(mapcar #'production-name (productions-list prod))
(mapcar 'production-name (productions-list prod))
productions)))
(dolist (p-name p)
(let ((production (get-production-internal p-name prod)))
......@@ -370,6 +393,13 @@
(if prod
(progn
(print-warning "Clearing the productions is not recommended")
(clrhash (procedural-cond-style-usage-table prod))
(clrhash (procedural-req-style-usage-table prod))
(clrhash (procedural-mod-style-usage-table prod))
(clrhash (procedural-retrieval-cond-style-usage-table prod))
(clrhash (procedural-retrieval-req-style-usage-table prod))
(dolist (p (productions-list prod))
(remove-production p prod)))
(print-warning "No procedural module was found."))))
......@@ -490,16 +520,15 @@
(print-production production)
(command-output "It fails because: ")
(command-output (failure-reason-string (production-failure-condition production) procedural production))))))))
(command-output (failure-reason-string (production-failure-condition production) production))))))))
conflict-set)
(print-warning "Whynot called with no current model.")))
(defun production-failure-reason (p-name)
(let ((procedural (get-module procedural))
(production (get-production p-name)))
(let ((production (get-production p-name)))
(if (and production (production-failure-condition production))
(failure-reason-string (production-failure-condition production) procedural production)
(failure-reason-string (production-failure-condition production) production)
"")))
(defun pmatches ()
......@@ -543,10 +572,10 @@
(unless (production-disabled production)
(when (and (conflict-tests procedural (production-constants production) production 'test-constant-condition :report nil)
(conflict-tests procedural (production-binds production) production 'test-and-perfrom-bindings :report nil)
(conflict-tests procedural (production-binds production) production 'test-and-perform-bindings :report nil)
(conflict-tests procedural (production-others production) production 'test-other-condition :report nil)
(conflict-tests procedural (production-searches production) production 'test-search-buffers :report nil)
(conflict-tests procedural (production-search-binds production) production 'test-and-perfrom-bindings :report nil)
(conflict-tests procedural (production-search-binds production) production 'test-and-perform-bindings :report nil)
(conflict-tests procedural (production-search-others production) production 'test-other-condition :report nil)
)
......@@ -588,7 +617,7 @@
(defun p-fct (definition)
(let ((prod (get-module procedural)))
(if (procedural-p prod)
(create-production prod definition nil)
(create-production prod definition)
(print-warning "No procedural modulue found cannot create production."))))
......@@ -600,8 +629,37 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A command to avoid style warnings.
(defmacro declare-buffer-usage (buffer type &rest slots)
`(declare-buffer-usage-fct ',buffer ',type ',slots))
(defun declare-buffer-usage-fct (buffer type &optional slots)
(let ((procedural (get-module procedural)))
(if procedural
(cond ((not (find buffer (buffers)))
(print-warning "Cannot declare usage for ~S because it does not name a buffer in the model." buffer))
((not (chunk-type-p-fct type))
(print-warning "Cannot declare usage for buffer ~s because ~s does not name a chunk-type in the model." buffer type))
((not (or (eq slots :all)
(and (listp slots) (= (length slots) 1) (eq (car slots) :all))
(every (lambda (x)
(valid-chunk-type-slot type x))
slots)))
(print-warning "Cannot declare usage for buffer ~s because the slots (~{~s~^ ~}) are not valid for chunk-type ~s."
buffer (remove-if (lambda (x)
(valid-chunk-type-slot type x))
slots)
type))
(t
(when (or (eq slots :all)
(and (listp slots) (= (length slots) 1) (eq (car slots) :all)))
(setf slots (chunk-type-possible-slot-names-fct type)))
(dolist (s slots) (push s (gethash buffer (procedural-cond-style-usage-table procedural))))
(dolist (s slots) (push s (gethash buffer (procedural-init-chunk-slots procedural))))
t))
(print-warning "No procedural module found. Cannot declare buffer usage."))))
......
This diff is collapsed.
This diff is collapsed.
......@@ -13,7 +13,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Filename : goal.lisp
;;; Version : 1.1
;;; Version : 2.0
;;;
;;; Description : Implementation of the goal module.
;;;
......@@ -86,12 +86,23 @@
;;; 2008.09.19 Dan
;;; : * Moved the mod-request function to goal-style support
;;; : and changed the goal module's definition to use it.
;;; 2013.03.20 Dan
;;; : * Minor edits while verifying that it'll work with the typeless
;;; : chunk mechanism.
;;; 2015.02.11 Dan [2.0]
;;; : * Change the default value for :ga from 1 to 0. The imaginal
;;; : buffer is now the only one which spreads activation by default.
;;; : Should have made this change with the first version of 6.1.
;;; 2015.06.04 Dan
;;; : * Use :time-in-ms t for all the scheduled events.
;;; 2015.07.28 Dan
;;; : * Changed the logical to ACT-R-support in the require-compiled.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; General Docs:
;;;
;;; The goal module has one buffer called goal.
;;; The source spread parameter of the goal is called :ga and defaults to 1.
;;; The source spread parameter of the goal is called :ga and defaults to 0.
;;;
;;; The goal module responds to requests by creating a new chunk and placing it
;;; into the buffer. The requests must be a unique specification of a chunk.
......@@ -149,7 +160,7 @@
;;; Rely on the general functions in the goal-style-module
(require-compiled "GOAL-STYLE-MODULE" "ACT-R6:support;goal-style-module")
(require-compiled "GOAL-STYLE-MODULE" "ACT-R-support:goal-style-module")
;;; Only need to record the chunk that will be stuffed into the buffer
......@@ -184,9 +195,9 @@
;;; Actually define the module now
(define-module-fct 'goal '((goal (:ga 1.0)))
(define-module-fct 'goal '((goal (:ga 0.0)))
nil
:version "1.1"
:version "2.0"
:documentation "The goal module creates new goals for the goal buffer"
:creation #'create-goal-module
:query #'goal-query
......@@ -212,22 +223,16 @@
(if chunk-name
(if (chunk-p-fct chunk-name)
(progn
;; Should it clear it immediately first?
(schedule-set-buffer-chunk 'goal chunk-name 0 :module 'goal
:priority :max :requested nil)
(schedule-event-after-module 'goal #'clear-delayed-goal :module 'goal
:output nil
:destination 'goal
:maintenance t)
(schedule-set-buffer-chunk 'goal chunk-name 0 :time-in-ms t :module 'goal :priority :max :requested nil)
(schedule-event-after-module 'goal 'clear-delayed-goal :module 'goal :output nil
:destination 'goal :maintenance t)
(setf (goal-module-delayed g-module) chunk-name)
chunk-name)
;; This is a serious problem so don't use model-warning
(print-warning
"~S is not the name of a chunk in the current model - goal-focus failed"
chunk-name))
(print-warning "~S is not the name of a chunk in the current model - goal-focus failed" chunk-name))
(let ((chunk (buffer-read 'goal))
(delayed (goal-module-delayed g-module)))
......@@ -235,8 +240,7 @@
(command-output "Goal buffer is empty")
nil)
((null chunk)
(command-output "Will be a copy of ~a when the model runs"
delayed)
(command-output "Will be a copy of ~a when the model runs" delayed)
(pprint-chunks-fct (list delayed))
delayed)
((null delayed)
......@@ -249,8 +253,7 @@
(pprint-chunks-fct (list chunk))
chunk)
(progn
(command-output "Will be a copy of ~a when the model runs"
delayed)
(command-output "Will be a copy of ~a when the model runs" delayed)
(command-output "Currently holds:")
(pprint-chunks-fct (list chunk))
delayed))))))))
......@@ -268,17 +271,13 @@
(let ((chunk (buffer-read 'goal)))
(if chunk
(progn
(schedule-event-relative 0 'goal-modification
:module 'goal
:priority :max
:output 'medium)
(schedule-event-now 'goal-modification :module 'goal :priority :max :output 'medium)
(mod-chunk-fct chunk modifications))
(print-warning "No chunk in the goal buffer to modify"))))
(defun goal-modification ()
"Dummy function for mod-focus event"
nil)
"Dummy function for mod-focus event")
#|
This library is free software; you can redistribute it and/or
......
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
;;; -*- mode: LISP; Package: CL-USER; Syntax: COMMON-LISP; Base: 10 -*-
;;; -*- mode: LISP; Syntax: COMMON-LISP; Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Author : Dan Bothell
......@@ -67,6 +67,17 @@
;;; : * Noted the bug about :on-click under Linux, which isn't an
;;; : issue for now since the Linux interface doesn't work for a
;;; : model anyway.
;;; 2013.01.23 Dan
;;; : * Added a before method on virtual-key-down for button-panes
;;; : because sometimes those seem to get the key presses instead
;;; : of the "key catcher" so pass the press "up" to the window
;;; : in those cases too.
;;; 2014.04.09 Dan
;;; : * Call rpm-window-click-event-handler with a position vector
;;; : because that matches what the get-mouse-coordinates method
;;; : returns.
;;; 2015.05.26 Dan
;;; : * Added a font-size parameter to make-static-text-for-rpm-window.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#+:packaged-actr (in-package :act-r)
......@@ -90,8 +101,8 @@
(declare (ignore buttons))
(when (null cur-pos)
(setf cur-pos (cg:cursor-position device)))
(rpm-window-click-event-handler device (list (position-x cur-pos)
(position-y cur-pos))))
(rpm-window-click-event-handler device (vector (position-x cur-pos)
(position-y cur-pos))))
(defmethod rpm-window-click-event-handler ((device rpm-real-window) position)
(declare (ignore position))
......@@ -173,17 +184,19 @@
(defmethod make-button-for-rpm-window ((win rpm-real-window) &key (x 0) (y 0) (text "Ok") (action nil) (height 18) (width 60) (color 'black))
(make-instance 'cg:button
:left x
:width width
:height height
:on-click #'(lambda (window button) (declare (ignore window)) (when action (funcall action button)))
:title text
:left x
:width width
:height height
:on-click #'(lambda (window button) (declare (ignore window)) (when action (funcall action button)))
:title text
:top y
:foreground-color (color-symbol->system-color color)))
;;; Windows
(defmethod make-static-text-for-rpm-window ((win rpm-real-window) &key (x 0) (y 0) (text "") (height 20) (width 20) (color 'black))
(defmethod make-static-text-for-rpm-window ((win rpm-real-window) &key (x 0) (y 0) (text "") (height 20) (width 20) (color 'black) font-size)
(unless (numberp font-size)
(setf font-size 12))
(make-instance 'cg:static-text
:left x
:width width
......@@ -191,7 +204,8 @@
:value text
:top y
:foreground-color (color-symbol->system-color color)
:on-click #'(lambda (x y) (declare (ignore x y)) (mouse-left-down win nil nil))))
:on-click #'(lambda (x y) (declare (ignore x y)) (mouse-left-down win nil nil))
:font (make-font-ex :modern "courier new" (points-to-pixels font-size))))
;;; It turns out that due to the bottom up nature of
......@@ -241,6 +255,12 @@
(virtual-key-down (cg:parent catcher) buttons key-code)))
#+(version>= 8 0) (defmethod virtual-key-down :before ((catcher cg::button-pane) buttons key-code)
(when (subtypep (type-of (cg:parent catcher)) 'rpm-window)
(virtual-key-down (cg:parent catcher) buttons key-code)))
(defun make-rpm-window (&key (visible nil) (class nil) (title "RPM Window") (width 100) (height 100) (x 0 ) (y 0))
(if visible
(if (and (visible-virtuals-available?) (null class))
......
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
File added
File added
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
File mode changed from 100644 to 100755
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.