From 5a407301f8b9d2826b23630d8df65096374d5079 Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Mon, 24 Apr 2017 07:30:38 -0500 Subject: [PATCH] CLI Extension - Button press --- src/main/extensions.lisp | 69 ++++++++++++++++++---------- src/main/extensions/cli/cli.lisp | 16 ++----- src/main/extensions/cli/package.lisp | 1 - src/main/model.lisp | 23 ++++++++++ src/main/package.lisp | 4 +- src/main/parse.lisp | 3 +- 6 files changed, 76 insertions(+), 40 deletions(-) diff --git a/src/main/extensions.lisp b/src/main/extensions.lisp index 6755d50..fda3788 100644 --- a/src/main/extensions.lisp +++ b/src/main/extensions.lisp @@ -1,5 +1,27 @@ (in-package #:clnl-extensions) +(defgeneric prims (extension) + (:documentation + "PRIMS EXTENSION => PRIMS + + PRIMS: PRIM* + PRIM: (:name NAME :type TYPE :args ARGS :func FUNC) + TYPE: :command | :reporter + ARGS: ARG* + +ARGUMENTS AND VALUES: + + EXTENSION: a symbol in the keyword package representing this extension + NAME: a symbol in the keyword package + FUNC: the function to call + ARG: a list of symbols denoting the type of argument + +DESCRIPTION: + + PRIMS returns the primitives used in the extension passed in. + + See CLNL-PARSER:PARSE for more information on the PRIM returned.")) + (defun load-extension (extension) "LOAD-EXTENSION EXTENSION => PRIMS @@ -22,28 +44,25 @@ DESCRIPTION: (let ((pkg (find-package name))) (when (or (not pkg)) (error "Can't find package with extension name: ~A" name)) - (multiple-value-bind (symb status) (find-symbol "PRIMS" pkg) - (when (not symb) (error "Can't find PRIMS function within extension: ~A" name)) - (when (not (eql status :external)) (error "PRIMS function is not external in extension: ~A" name)) - (when (not (and (fboundp symb) (not (macro-function symb)) (not (special-operator-p symb)))) - (error "PRIMS is not a function in ~A" name)) - (mapcar - (lambda (prim) - (when (not (getf prim :name)) (error "Prim requires a name: ~A ~A" name prim)) - (let - ((type (getf prim :type))) - (when (or (not type) (not (find type '(:reporter :command)))) - (error "Prim type invalid, needs to be :reporter or :command: ~A ~A ~A" name prim type))) - (when (not (getf prim :func)) - (error "Prim needs a func: ~A ~A" name prim)) - (list - :name (intern - (format nil "~A:~A" - (if (eql extension :cli) "" (string-upcase extension)) - (string-upcase (getf prim :name))) - :keyword) - :type (getf prim :type) - :precedence (or (getf prim :precedence) (if (eql :reporter (getf prim :type)) 10 0)) - :args (getf prim :args) - :func (getf prim :func))) - (funcall (symbol-function symb))))))) + (when (not (compute-applicable-methods #'prims (list extension))) + (error "Can't find implemented PRIMS method within extension: ~A" name)) + (mapcar + (lambda (prim) + (when (not (getf prim :name)) (error "Prim requires a name: ~A ~A" name prim)) + (let + ((type (getf prim :type))) + (when (or (not type) (not (find type '(:reporter :command)))) + (error "Prim type invalid, needs to be :reporter or :command: ~A ~A ~A" name prim type))) + (when (not (getf prim :func)) + (error "Prim needs a func: ~A ~A" name prim)) + (list + :name (intern + (format nil "~A:~A" + (if (eql extension :cli) "" (string-upcase extension)) + (string-upcase (getf prim :name))) + :keyword) + :type (getf prim :type) + :precedence (or (getf prim :precedence) (if (eql :reporter (getf prim :type)) 10 0)) + :args (getf prim :args) + :func (getf prim :func))) + (prims extension))))) diff --git a/src/main/extensions/cli/cli.lisp b/src/main/extensions/cli/cli.lisp index 4a44546..9faddaa 100644 --- a/src/main/extensions/cli/cli.lisp +++ b/src/main/extensions/cli/cli.lisp @@ -1,19 +1,13 @@ (in-package #:clnl-extension-cli) -(defun prims () - "PRIMS => PRIMS - -ARGUMENTS AND VALUES: - - PRIMS: Primitives defined for this extension - -DESCRIPTION: - - PRIMS returns the primitives used in the CLI extension." +(defmethod clnl-extensions:prims ((extension (eql :cli))) (list (list :name :q :type :command :func #'shut-down) (list :name :load :type :command :args '(t) :func #'load-file) - (list :name :help :type :command :args '((:token :optional)) :precedence 20 :func #'help))) + (list :name :help :type :command :args '((:token :optional)) :precedence 20 :func #'help) + (list + :name :button :type :command :args '(:string (:optional :number)) + :precedence 20 :func #'clnl-model:execute-button))) (defun shut-down () (sb-ext:exit :abort t)) diff --git a/src/main/extensions/cli/package.lisp b/src/main/extensions/cli/package.lisp index 00873dc..486affb 100644 --- a/src/main/extensions/cli/package.lisp +++ b/src/main/extensions/cli/package.lisp @@ -1,6 +1,5 @@ (defpackage #:clnl-extension-cli (:use :common-lisp) - (:export #:prims) (:documentation "CLI Extension diff --git a/src/main/model.lisp b/src/main/model.lisp index 5e0dde7..5d7e9e3 100644 --- a/src/main/model.lisp +++ b/src/main/model.lisp @@ -196,6 +196,29 @@ DESCRIPTION: (when parser (funcall (cadr parser) widget-as-strings)))) widgets-as-strings)))) +; With authoring, idx here needs to be looked at again. +(defun execute-button (name &optional (idx 0)) + "EXECUTE-BUTTON NAME &optional IDX => RESULT + +ARGUMENTS AND VALUES: + + NAME: the name of the button + IDX: the instance of the button, defaults to 0 + RESULT: undefined + +DESCRIPTION: + + Executes the code in the button referenced by NAME and IDX. + + NAME refers to the display name for the button, which is usually + set by the model, but sometimes defaults to the code inside. + + Because NAME is not guaranteed to be unique, IDX is available + as a specifier. The index is in the order that the buttons are + loaded, and cannot be guaranteed to be stable from run to run." + (declare (ignore name idx)) + nil) + ;; INFORMATION ABOUT MODEL (defun world-dimensions (model) diff --git a/src/main/package.lisp b/src/main/package.lisp index 2f2c5c6..d750125 100644 --- a/src/main/package.lisp +++ b/src/main/package.lisp @@ -85,7 +85,7 @@ components.")) (defpackage #:clnl-model (:use :common-lisp) - (:export #:default-model #:read-from-nlogo #:world-dimensions #:widget-globals #:code) + (:export #:execute-button #:default-model #:read-from-nlogo #:world-dimensions #:widget-globals #:code) (:documentation "CLNL Model @@ -96,7 +96,7 @@ as clnl runs.")) (defpackage #:clnl-extensions (:use :common-lisp) - (:export #:load-extension) + (:export #:load-extension #:prims) (:documentation "CLNL Extensions diff --git a/src/main/parse.lisp b/src/main/parse.lisp index 6197d30..196b63b 100644 --- a/src/main/parse.lisp +++ b/src/main/parse.lisp @@ -68,7 +68,8 @@ DESCRIPTION: lowest precedence, and all reporters should have 10 as the precedence. The possible values for ARG are :agentset, :boolean, :number, :command-block, - or t for wildcard. + :string, or t for wildcard. For optional arguments, ARG can be a list of the form + (ARG :optional) where ARG is one of the aforementioned values. The need for a parser between the lexer and the transpiler is because NetLogo needs two passes to turn into something that can be used. This is the only entry -- 2.25.1