From c739aec9e225747148c14c0c3b76f4147ff7be81 Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Wed, 11 May 2016 15:06:29 -0500 Subject: [PATCH 01/16] Prims - Implement turtles-here --- src/main/nvm/base.lisp | 2 +- src/main/nvm/nvm.lisp | 36 ++++++++++++++++++++++++++++-------- src/main/nvm/utils.lisp | 22 ++++++++++++++++++++++ src/main/package.lisp | 1 + src/main/parse.lisp | 1 + src/main/transpile.lisp | 1 + src/test/simpletests.lisp | 4 ++++ 7 files changed, 58 insertions(+), 9 deletions(-) diff --git a/src/main/nvm/base.lisp b/src/main/nvm/base.lisp index 945c5e8..294715a 100644 --- a/src/main/nvm/base.lisp +++ b/src/main/nvm/base.lisp @@ -32,7 +32,7 @@ DESCRIPTION: `(handler-case (progn ,@forms) (stop (s) (declare (ignore s)) :stop))) (defstruct turtle who color heading xcor ycor (label "") (label-color 9.9d0) (size 1d0) shape own-vars) -(defstruct patch color xcor ycor own-vars) +(defstruct patch color xcor ycor own-vars turtles) (defun agentset-list (agentset) (cond diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp index 42a269a..bcf4be1 100644 --- a/src/main/nvm/nvm.lisp +++ b/src/main/nvm/nvm.lisp @@ -61,6 +61,9 @@ DESCRIPTION: :shape (breed-default-shape :turtles) :xcor (if base-turtle (turtle-xcor base-turtle) 0d0) :ycor (if base-turtle (turtle-ycor base-turtle) 0d0)))) + (let + ((patch (patch-at (turtle-xcor new-turtle) (turtle-ycor new-turtle)))) + (setf (patch-turtles patch) (nconc (patch-turtles patch) (list new-turtle)))) (setf *turtles* (nconc *turtles* (list new-turtle))) (incf *current-id*) new-turtle)) @@ -122,6 +125,22 @@ DESCRIPTION: See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles" :turtles) +(defun turtles-here () + "TURTLES-HERE => TURTLES + +ARGUMENTS AND VALUES: + + TURTLES: an agentset + +DESCRIPTION: + + Returns the agentset consisting of all the turtles sharing the patch + with the agent in by *self* + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles-here" + (when (not (turtle-p *self*)) (error "Gotta call turtles-here with a turtle")) + (list->agentset (patch-turtles (patch-at (turtle-xcor *self*) (turtle-ycor *self*))) :turtles)) + (defun ask (agent-or-agentset fn) "ASK AGENT-OR-AGENTSET FN => RESULT @@ -422,14 +441,15 @@ DESCRIPTION: (defun jump (n) (when (not (turtle-p *self*)) (error "Gotta call jump in turtle scope, dude (~A)" *self*)) - (setf - (turtle-xcor *self*) - (wrap-x *topology* - (+ (turtle-xcor *self*) (* n (using-cached-sin (turtle-heading *self*)))))) - (setf - (turtle-ycor *self*) - (wrap-y *topology* - (+ (turtle-ycor *self*) (* n (using-cached-cos (turtle-heading *self*))))))) + (with-patch-update *self* + (setf + (turtle-xcor *self*) + (wrap-x *topology* + (+ (turtle-xcor *self*) (* n (using-cached-sin (turtle-heading *self*)))))) + (setf + (turtle-ycor *self*) + (wrap-y *topology* + (+ (turtle-ycor *self*) (* n (using-cached-cos (turtle-heading *self*)))))))) (defun setxy (x y) "SETXY X Y => RESULT diff --git a/src/main/nvm/utils.lisp b/src/main/nvm/utils.lisp index a656df3..f95fb7f 100644 --- a/src/main/nvm/utils.lisp +++ b/src/main/nvm/utils.lisp @@ -26,3 +26,25 @@ (defun using-cached-cos (n) (if (= (floor n) n) (nth (floor n) *cached-coses*) (strictmath:cos (strictmath:to-radians n)))) + +(defun patch-at (xcor ycor) + (flet + ((rnd (d) (truncate (if (< d 0) (- d 0.5d0) (+ d 0.5d0))))) + (or + (find-if + (lambda (patch) + (and (equalp (patch-xcor patch) (rnd xcor)) (equalp (patch-ycor patch) (rnd ycor)))) + *patches*) + (error "This shouldn't be possible: ~S ~S ~S" (rnd xcor) (rnd ycor) *patches*)))) + +(defmacro with-patch-update (turtle &rest forms) + (let + ((patch (gensym)) (new-patch (gensym))) + `(let + ((,patch (patch-at (turtle-xcor ,turtle) (turtle-ycor ,turtle))) + (retn (progn ,@forms))) + (let + ((,new-patch (patch-at (turtle-xcor ,turtle) (turtle-ycor ,turtle)))) + (when (not (eql ,patch ,new-patch)) + (setf (patch-turtles ,patch) (remove ,turtle (patch-turtles ,patch))) + (setf (patch-turtles ,new-patch) (nconc (patch-turtles ,new-patch) (list ,turtle)))))))) diff --git a/src/main/package.lisp b/src/main/package.lisp index 92796dc..ac81d3f 100644 --- a/src/main/package.lisp +++ b/src/main/package.lisp @@ -92,6 +92,7 @@ into an ast that can be transpiled later.")) #:show #:stop #:turtles + #:turtles-here #:tick #:ticks #:turn-right #:turn-left diff --git a/src/main/parse.lisp b/src/main/parse.lisp index 6d45ed5..a44caea 100644 --- a/src/main/parse.lisp +++ b/src/main/parse.lisp @@ -321,6 +321,7 @@ DESCRIPTION: (defprim :tick () 0) (defprim :ticks () 10) (defprim :turtles () 10) +(defprim :turtles-here () 10) (defprim :who () 10) ; colors diff --git a/src/main/transpile.lisp b/src/main/transpile.lisp index 327bdbd..b140653 100644 --- a/src/main/transpile.lisp +++ b/src/main/transpile.lisp @@ -226,6 +226,7 @@ DESCRIPTION: (defsimpleprim :tick :command clnl-nvm:tick) (defsimpleprim :ticks :reporter clnl-nvm:ticks) (defsimpleprim :turtles :reporter clnl-nvm:turtles) +(defsimpleprim :turtles-here :reporter clnl-nvm:turtles-here) (defagentvalueprim :who) (defsimpleprim :with :reporter clnl-nvm:with) diff --git a/src/test/simpletests.lisp b/src/test/simpletests.lisp index 4963164..9bf58d3 100644 --- a/src/test/simpletests.lisp +++ b/src/test/simpletests.lisp @@ -265,3 +265,7 @@ (defsimplecommandtest "stop 2" "crt 10 ask turtles [ fd 1 stop fd 1 ]" "A6C980CC9843CDD211ABD9C13899010D555F3DC5") + +(defsimplecommandtest "turtles-here 1" + "crt 1000 ask turtles [ fd random-float 10 ] ask turtles [ set label [ who ] of one-of turtles-here ]" + "F34192513765D221A15D939A2BC8FFE18B6ADF4C") -- 2.25.1 From bc6386a709da76fef1393a11a7251b4be7032fda Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Fri, 13 May 2016 15:07:47 -0500 Subject: [PATCH 02/16] Code - breeds --- bin/runcmd.scala | 21 ++++++++ src/main/code-parse.lisp | 54 +++++++++++++++----- src/main/main.lisp | 104 +++++++++++++++++++-------------------- src/main/nvm/base.lisp | 6 ++- src/main/nvm/nvm.lisp | 53 +++++++++++++------- src/main/package.lisp | 2 +- src/main/parse.lisp | 22 +++++++-- src/main/transpile.lisp | 2 +- src/test/modeltests.lisp | 22 +++++++++ 9 files changed, 196 insertions(+), 90 deletions(-) diff --git a/bin/runcmd.scala b/bin/runcmd.scala index f466887..b91ed4e 100755 --- a/bin/runcmd.scala +++ b/bin/runcmd.scala @@ -63,6 +63,27 @@ ticks @#$#@#$#@ @#$#@#$#@ +default +true +0 +Polygon -7500403 true true 150 5 40 250 150 205 260 250 + +sheep +false +15 +Circle -1 true true 203 65 88 +Circle -1 true true 70 65 162 +Circle -1 true true 150 105 120 +Polygon -7500403 true false 218 120 240 165 255 165 278 120 +Circle -7500403 true false 214 72 67 +Rectangle -1 true true 164 223 179 298 +Polygon -1 true true 45 285 30 285 30 240 15 195 45 210 +Circle -1 true true 3 83 150 +Rectangle -1 true true 65 221 80 296 +Polygon -1 true true 195 285 210 285 210 240 240 210 195 210 +Polygon -7500403 true false 276 85 285 105 302 99 294 83 +Polygon -7500403 true false 219 85 210 105 193 99 201 83 + @#$#@#$#@ NetLogo 5.2.0""") } else { diff --git a/src/main/code-parse.lisp b/src/main/code-parse.lisp index b2a9e45..1cb6662 100644 --- a/src/main/code-parse.lisp +++ b/src/main/code-parse.lisp @@ -9,18 +9,34 @@ (defvar *dynamic-prims* nil) (defun global->prim (global) - (list :name global :type :reporter :macro `(lambda () ',(intern (symbol-name global) clnl:*model-package*)))) + (list + :name global + :type :reporter + :precedence 10 + :macro `(lambda () ',(intern (symbol-name global) clnl:*model-package*)))) (defun own->prim (symb) - (list :name symb :type :reporter :macro `(lambda () '(clnl-nvm:agent-value ,symb)))) + (list :name symb :type :reporter :precedence 10 :macro `(lambda () '(clnl-nvm:agent-value ,symb)))) (defun breed->prims (breed-list) - (let - ((plural-name (symbol-name (car breed-list)))) + (let* + ((plural (car breed-list)) + (singular (cadr breed-list)) + (plural-name (symbol-name plural))) (list - (list :name (car breed-list)) - (list :name (intern (format nil "~A-HERE" plural-name) :keyword)) - (list :name (intern (format nil "CREATE-~A" plural-name) :keyword) :args '(:number :command-block))))) + (list :name plural :type :reporter :precedence 10 :macro `(lambda () ,plural)) + (list + :name (intern (format nil "~A-HERE" plural-name) :keyword) + :type :reporter + :precedence 10 + :macro `(lambda () '(clnl-nvm:turtles-here ,plural))) + (list + :name (intern (format nil "CREATE-~A" plural-name) :keyword) + :type :command + :args '(:number (:command-block :optional)) + :precedence 0 + :macro `(lambda (num &optional command-block) + `(clnl-nvm:create-turtles ,num ,,plural ,command-block)))))) (defun parse (lexed-ast &optional external-globals) "PARSE LEXED-AST &optional EXTERNAL-GLOBALS => AST, PRIMS @@ -67,6 +83,7 @@ DESCRIPTION: (list :name (cadr lexed-ast) :type :command + :precedence 0 :func `(function ,(intern (symbol-name (cadr lexed-ast)) clnl:*model-package*))) (procedures->prims (cddr lexed-ast)))) (t (procedures->prims (cdr lexed-ast))))) @@ -163,9 +180,7 @@ ARGUMENTS AND VALUES: DESCRIPTION: Returns the turtles own variables that get declared in the code." - (mapcar - (lambda (turtles-own-var) (intern (symbol-name turtles-own-var) :keyword)) - (cdr (second (find :turtles-own code-parsed-ast :key #'car))))) + (cdr (second (find :turtles-own code-parsed-ast :key #'car)))) (defun patches-own-vars (code-parsed-ast) "PATCHES-OWN-VARS CODE-PARSED-AST => PATCHES-OWN-VARS @@ -180,9 +195,22 @@ ARGUMENTS AND VALUES: DESCRIPTION: Returns the turtles own variables that get declared in the code." - (mapcar - (lambda (patches-own-var) (intern (symbol-name patches-own-var) :keyword)) - (cdr (second (find :patches-own code-parsed-ast :key #'car))))) + (cdr (second (find :patches-own code-parsed-ast :key #'car)))) + +(defun breeds (code-parsed-ast) + "BREEDS CODE-PARSED-AST => BREEDS + + BREEDS: BREED* + +ARGUMENTS AND VALUES: + + CODE-PARSED-AST: An ast as created by clnl-code-parse:parse + BREED: A symbol interned in :keyword + +DESCRIPTION: + + Returns the breeds that get declared in the code." + (mapcar #'cadadr (remove :breed code-parsed-ast :test-not #'equal :key #'car))) (defun procedures (code-parsed-ast) "PROCEDURES CODE-PARSED-AST => PROCEDURES diff --git a/src/main/main.lisp b/src/main/main.lisp index 29c50ea..35a5961 100644 --- a/src/main/main.lisp +++ b/src/main/main.lisp @@ -83,6 +83,47 @@ DESCRIPTION: stages need to turn them into Common Lisp code, run it, and return the RESULT." (eval (clnl-transpiler:transpile (clnl-parser:parse (clnl-lexer:lex reporter))))) +; Because prims are used both at generation time and later at runtime, certain things in +; them must be escaped a little bit more, such as wrapping the whole thing in a list +; primitive. This way, the output of these things looks like halfway decent lisp, +; and everything works nicely. We don't want any showing up or anything +(defun munge-prim (prim) + (let + ((copied (copy-list prim))) + (when (getf copied :args) (setf (getf copied :args) `(quote ,(getf copied :args)))) + `(list ,@copied))) + +(defun netlogo-callback-body (prims) + `(eval + (clnl-transpiler:transpile + (clnl-parser:parse + (clnl-lexer:lex ,(intern "NETLOGO-CODE" *model-package*)) + (list ,@(mapcar #'munge-prim prims))) + (list ,@(mapcar #'munge-prim prims))))) + +(defun create-world-call (model globals code-ast) + `(clnl-nvm:create-world + :dims ',(clnl-model:world-dimensions model) + :globals (list + ,@(mapcar + (lambda (pair) + `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*)))) + globals)) + :turtles-own-vars ',(clnl-code-parser:turtles-own-vars code-ast) + :patches-own-vars ',(clnl-code-parser:patches-own-vars code-ast) + :breeds ',(clnl-code-parser:breeds code-ast))) + +(defun create-proc-body (proc prims) + `(,(intern (string-upcase (car proc)) *model-package*) () + ,@(cdr ; remove the progn, cuz it looks nicer + (clnl-transpiler:transpile (cadr proc) + (mapcar + (lambda (prim) + (if (getf prim :macro) ; The reason we do this is because with macros, we want to evaluate them in + ; this scope while preserving them for the generational purposes below + (append (list :macro (eval (getf prim :macro))) prim) + prim)) prims))))) + (defun model->single-form-lisp (model &key (seed 15) initialize-interface netlogo-callback) (multiple-value-bind (code-ast prims) @@ -94,43 +135,23 @@ DESCRIPTION: (clnl-code-parser:globals code-ast)))) `(prog () ; First declare is in case we don't use it, it shows up in export correctly - (declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals))) + ,@(when (and (> (length globals) 0) netlogo-callback) + `((declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals))))) (let ,(mapcar (lambda (pair) (list (intern (string-upcase (car pair)) *model-package*) (cadr pair))) globals) ; We declare twice rather than once and doing a bunch of setfs - (declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals))) + ,@(when (and (> (length globals) 0) netlogo-callback) + `((declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals))))) (labels ,(mapcar - (lambda (proc) - `(,(intern (string-upcase (car proc)) *model-package*) () - ,@(cdr ; remove the progn, cuz it looks nicer - (clnl-transpiler:transpile (cadr proc) - (mapcar - (lambda (prim) - (if (getf prim :macro) ; The reason we do this is because with macros, we want to evaluate them in - ; this scope while preserving them for the generational purposes below - (append (list :macro (eval (getf prim :macro))) prim) - prim)) prims))))) + (lambda (proc) (create-proc-body proc prims)) (clnl-code-parser:procedures code-ast)) (clnl-random:set-seed ,seed) - (clnl-nvm:create-world - :dims ',(clnl-model:world-dimensions model) - :globals (list - ,@(mapcar - (lambda (pair) - `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*)))) - globals)) - :turtles-own-vars ',(clnl-code-parser:turtles-own-vars code-ast) - :patches-own-vars ',(clnl-code-parser:patches-own-vars code-ast)) + ,(create-world-call model globals code-ast) ,@(when netlogo-callback `((funcall ,netlogo-callback - (lambda (netlogo-code) - (eval - (clnl-transpiler:transpile - (clnl-parser:parse - (clnl-lexer:lex netlogo-code) - (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims))) - (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims)))))))) + (lambda (,(intern "NETLOGO-CODE" *model-package*)) + ,(netlogo-callback-body prims))))) ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model)))))))))) (setf (documentation 'model->single-form-lisp 'function) @@ -175,36 +196,15 @@ DESCRIPTION: `(defvar ,(intern (string-upcase (car pair)) *model-package*) ,(cadr pair))) globals) ,@(mapcar - (lambda (proc) - `(defun ,(intern (string-upcase (car proc)) *model-package*) () - ,@(cdr ; remove the progn, cuz it looks nicer - (clnl-transpiler:transpile (cadr proc) - (mapcar - (lambda (prim) - (if (getf prim :macro) ; The reason we do this is because with macros, we want to evaluate them in - ; this scope while preserving them for the generational purposes below - (append (list :macro (eval (getf prim :macro))) prim) - prim)) prims))))) + (lambda (proc) `(defun ,@(create-proc-body proc prims))) (clnl-code-parser:procedures code-ast)) (defun ,boot-fn () (clnl-random:set-seed ,seed) - (clnl-nvm:create-world - :dims ',(clnl-model:world-dimensions model) - :globals (list - ,@(mapcar - (lambda (pair) `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*)))) - globals)) - :turtles-own-vars ',(clnl-code-parser:turtles-own-vars code-ast) - :patches-own-vars ',(clnl-code-parser:patches-own-vars code-ast)) + ,(create-world-call model globals code-ast) ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model))))) ,@(when netlogo-callback-fn `((defun ,netlogo-callback-fn (,(intern "NETLOGO-CODE" *model-package*)) - (eval - (clnl-transpiler:transpile - (clnl-parser:parse - (clnl-lexer:lex ,(intern "NETLOGO-CODE" *model-package*)) - (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims))) - (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims))))))))))) + ,(netlogo-callback-body prims)))))))) (setf (documentation 'model->multi-form-lisp 'function) "MODEL->MULTI-FORM-LISP MODEL BOOT-FN &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK-FN => FORMS diff --git a/src/main/nvm/base.lisp b/src/main/nvm/base.lisp index 294715a..063dfb5 100644 --- a/src/main/nvm/base.lisp +++ b/src/main/nvm/base.lisp @@ -31,7 +31,7 @@ DESCRIPTION: :stop is returned." `(handler-case (progn ,@forms) (stop (s) (declare (ignore s)) :stop))) -(defstruct turtle who color heading xcor ycor (label "") (label-color 9.9d0) (size 1d0) shape own-vars) +(defstruct turtle who breed color heading xcor ycor (label "") (label-color 9.9d0) (size 1d0) shape own-vars) (defstruct patch color xcor ycor own-vars turtles) (defun agentset-list (agentset) @@ -39,12 +39,15 @@ DESCRIPTION: ((eql agentset :turtles) *turtles*) ((eql agentset :patches) *patches*) ((and (listp agentset) (eql :agentset (car agentset))) (cddr agentset)) + ((find agentset *breeds* :key #'car) + (remove agentset *turtles* :key #'turtle-breed :test-not #'eql)) (t (error "Doesn't seem to be an agentset: ~A" agentset)))) (defun agentset-breed (agentset) (cond ((eql agentset :turtles) :turtles) ((eql agentset :patches) :patches) + ((find agentset *breeds* :key #'car) agentset) ((and (listp agentset) (eql :agentset (car agentset))) (second agentset)) (t (error "Doesn't seem to be an agentset: ~A" agentset)))) @@ -55,6 +58,7 @@ DESCRIPTION: (or (eql o :turtles) (eql o :patches) + (find o *breeds* :key #'car) (and (listp o) (eql :agentset (car o))))) (defun agent-p (o) diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp index bcf4be1..0981332 100644 --- a/src/main/nvm/nvm.lisp +++ b/src/main/nvm/nvm.lisp @@ -48,9 +48,10 @@ DESCRIPTION: (:magenta 125d0) (:pink 135d0))) -(defun create-turtle (&optional base-turtle) - (let - ((new-turtle (make-turtle +(defun create-turtle (breed &optional base-turtle) + (let* + ((breed (or breed (and base-turtle (turtle-breed base-turtle)) :turtles)) + (new-turtle (make-turtle :who (coerce *current-id* 'double-float) :color (if base-turtle (turtle-color base-turtle) @@ -58,7 +59,8 @@ DESCRIPTION: :heading (if base-turtle (turtle-heading base-turtle) (coerce (clnl-random:next-int 360) 'double-float)) - :shape (breed-default-shape :turtles) + :breed breed + :shape (breed-default-shape breed) :xcor (if base-turtle (turtle-xcor base-turtle) 0d0) :ycor (if base-turtle (turtle-ycor base-turtle) 0d0)))) (let @@ -125,7 +127,7 @@ DESCRIPTION: See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles" :turtles) -(defun turtles-here () +(defun turtles-here (&optional breed) "TURTLES-HERE => TURTLES ARGUMENTS AND VALUES: @@ -139,7 +141,11 @@ DESCRIPTION: See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles-here" (when (not (turtle-p *self*)) (error "Gotta call turtles-here with a turtle")) - (list->agentset (patch-turtles (patch-at (turtle-xcor *self*) (turtle-ycor *self*))) :turtles)) + (let + ((patch-turtles (patch-turtles (patch-at (turtle-xcor *self*) (turtle-ycor *self*))))) + (list->agentset + (if breed (remove breed patch-turtles :key #'turtle-breed :test-not #'eql) patch-turtles) + (or breed :turtles)))) (defun ask (agent-or-agentset fn) "ASK AGENT-OR-AGENTSET FN => RESULT @@ -555,26 +561,28 @@ DESCRIPTION: See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right" (turn-right (- n))) -(defun create-turtles (n &optional fn) - "CREATE-TURTLES N &optional FN => RESULT +(defun create-turtles (n &optional breed fn) + "CREATE-TURTLES N &optional BREED FN => RESULT ARGUMENTS AND VALUES: N: an integer, the numbers of turtles to create + BREED: a breed FN: A function, applied to each turtle after creation RESULT: undefined DESCRIPTION: - Creates number new turtles at the origin. + Creates N new turtles at the origin. New turtles have random integer headings and the color is randomly selected - from the 14 primary colors. If a function is supplied, the new turtles - immediately run it. + from the 14 primary colors. If FN is supplied, the new turtles immediately + run it. If a BREED is supplied, that is the breed the new turtles are set + to. See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles" (let - ((new-turtles (loop :repeat n :collect (create-turtle)))) + ((new-turtles (loop :repeat n :collect (create-turtle breed)))) (when fn (ask (list->agentset new-turtles :turtles) fn)))) (defun hatch (n &optional fn) @@ -596,7 +604,7 @@ DESCRIPTION: See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#hatch" (when (not (turtle-p *self*)) (error "Can only hatch from turtle scope")) (let - ((new-turtles (loop :repeat n :collect (create-turtle *self*)))) + ((new-turtles (loop :repeat n :collect (create-turtle nil *self*)))) (when fn (ask (list->agentset new-turtles :turtles) fn)))) (defun reset-ticks () @@ -667,13 +675,14 @@ DESCRIPTION: (defun clear-ticks () (setf *ticks* nil)) -(defun create-world (&key dims globals turtles-own-vars patches-own-vars) - "CREATE-WORLD &key DIMS GLOBALS TURTLES-OWN-VARS PATCHES-OWN-VARS => RESULT +(defun create-world (&key dims globals turtles-own-vars patches-own-vars breeds) + "CREATE-WORLD &key DIMS GLOBALS TURTLES-OWN-VARS PATCHES-OWN-VARS BREEDS => RESULT DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX) GLOBALS: GLOBAL* TURTLES-OWN-VARS: TURTLES-OWN-VAR* PATCHES-OWN-VARS: PATCHES-OWN-VAR* + BREEDS: BREED* GLOBAL: (GLOBAL-NAME GLOBAL-ACCESS-FUNC) ARGUMENTS AND VALUES: @@ -685,6 +694,7 @@ ARGUMENTS AND VALUES: YMAX: An integer representing the maximum patch coord in Y TURTLES-OWN-VAR: Symbol for the turtles own variable in the keyword package PATCHES-OWN-VAR: Symbol for the patches own variable in the keyword package + BREED: A list of symbols representing the possible preeds GLOBAL-NAME: Symbol for the global in the keyword package GLOBAL-ACCESS-FUNC: Function to get the value of the global @@ -698,7 +708,10 @@ DESCRIPTION: (setf *patches-own-vars* patches-own-vars) (setf *dimensions* dims) (setf *globals* globals) - (setf *breeds* (list (list :turtles "default"))) + (setf *breeds* + (append + (list (list :turtles "default")) + (mapcar (lambda (breed) (list breed "default")) breeds))) (clear-ticks) (clear-patches) (clear-turtles)) @@ -730,6 +743,11 @@ DESCRIPTION: (defmethod dump-object ((o turtle)) (format nil "(turtle ~A)" (dump-object (turtle-who o)))) (defmethod dump-object ((o (eql :nobody))) (format nil "nobody")) +(defmethod dump-object ((o (eql :turtles))) (format nil "{all-turtles}")) +(defmethod dump-object ((o symbol)) + (cond + ((find o *breeds* :key #'car) (format nil "{breed ~(~A~)}" o)) + (t (error "Keyword unrecognized by dump object: ~A" o)))) (defun current-state () "CURRENT-STATE => WORLD-STATE @@ -779,7 +797,7 @@ DESCRIPTION: (mapcar (lambda (turtle) (format nil - "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"{all-turtles}\",\"false\",\"~A\",~A~{,\"~A\"~}" + "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"false\",\"~A\",~A~{,\"~A\"~}" (dump-object (turtle-who turtle)) (dump-object (turtle-color turtle)) (dump-object (turtle-heading turtle)) @@ -788,6 +806,7 @@ DESCRIPTION: (dump-object (turtle-shape turtle)) (dump-object (turtle-label turtle)) (dump-object (turtle-label-color turtle)) + (dump-object (turtle-breed turtle)) (dump-object (turtle-size turtle)) "\"1\",\"\"\"up\"\"\"" (mapcar #'dump-object (mapcar (lambda (var) (agent-value-inner turtle var)) *turtles-own-vars*)))) diff --git a/src/main/package.lisp b/src/main/package.lisp index ac81d3f..6db65fb 100644 --- a/src/main/package.lisp +++ b/src/main/package.lisp @@ -19,7 +19,7 @@ into an ast that can be transpiled later.")) (defpackage #:clnl-code-parser (:use :common-lisp) - (:export #:parse #:globals #:procedures #:turtles-own-vars #:patches-own-vars) + (:export #:parse #:globals #:procedures #:turtles-own-vars #:patches-own-vars #:breeds) (:documentation "CLNL Code Parser diff --git a/src/main/parse.lisp b/src/main/parse.lisp index a44caea..e3daa08 100644 --- a/src/main/parse.lisp +++ b/src/main/parse.lisp @@ -26,6 +26,7 @@ (defparameter *dynamic-prims* nil) (defun prim-name (prim) (getf prim :name)) +(defun prim-precedence (prim) (getf prim :precedence)) (defun prim-args (prim) (getf prim :args)) (defun prim-structure-prim (prim) (getf prim :structure-prim)) (defun prim-is-infix (prim) (getf prim :infix)) @@ -41,7 +42,7 @@ "PARSE LEXED-AST &optional DYNAMIC-PRIMS => AST DYNAMIC-PRIMS: DYNAMIC-PRIM* - DYNAMIC-PRIM: (:name NAME :args ARGS :infix INFIX) + DYNAMIC-PRIM: (:name NAME :args ARGS :infix INFIX :precedence PRECEDENCE) ARGS: ARG* ARGUMENTS AND VALUES: @@ -49,7 +50,8 @@ ARGUMENTS AND VALUES: LEXED-AST: An ambigious ast AST: An unambigious ast that can be transpiled NAME: A symbol in the keyword package - INFIX: Boolean denoting whether the prim is infix + INFIX: Boolean denoting whether the prim is infix, defaulting to NIL + PRECEDENCE: A number, usually 10 for reporters, and 0 for commands ARG: A list of symbols denoting the type of argument DESCRIPTION: @@ -58,7 +60,12 @@ DESCRIPTION: DYNAMIC-PRIMS that are passed in are used to avoid compilation errors on things not statically defined by the NetLogo language, be they user defined - procedures or generated primitives from breed declarations. + procedures or generated primitives from breed declarations. NAME and PRECEDENCE + are required for all dynamic prims. + + PRECEDENCE is a number used to calculate the order of operations. Higher numbers + have more precedence than lower ones. Generally all commands should have the + 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. @@ -72,6 +79,10 @@ DESCRIPTION: Examples are too numerous and varied, but by inserting an output between the lexer and this code, a good idea of what goes on can be gotten." + (when (find nil dynamic-prims :key #'prim-name) + (error "All passed in prims must have a name: ~S" (find nil dynamic-prims :key #'prim-name))) + (when (find nil dynamic-prims :key #'prim-precedence) + (error "All passed in prims must have a precedence: ~S" (find nil dynamic-prims :key #'prim-precedence))) (let ; could have defined this using the special variable, but didn't to make the ; function definition simpler, as well as the documentation. @@ -141,10 +152,10 @@ DESCRIPTION: (< 1 (length prev-item)) (keywordp (car x)) (find-prim (car x)) - (getf (find-prim (car x)) :precedence)) + (prim-precedence (find-prim (car x)))) 20))) (cond - ((<= (getf prim :precedence) (calculate-precedence prev-item)) + ((<= (prim-precedence prim) (calculate-precedence prev-item)) (cons (prim-name prim) (cons @@ -285,6 +296,7 @@ DESCRIPTION: (defprim :ca () 0) (defprim :clear-all () 0) (defprim :crt (:number (:command-block :optional)) 0) +(defprim :create-turtles (:number (:command-block :optional)) 0) (defprim :color () 10) (defprim :count (:agentset) 10) (defprim :die () 0) diff --git a/src/main/transpile.lisp b/src/main/transpile.lisp index b140653..91af23a 100644 --- a/src/main/transpile.lisp +++ b/src/main/transpile.lisp @@ -188,7 +188,7 @@ DESCRIPTION: (defagentvalueprim :color) (defsimpleprim '(:clear-all :ca) :command clnl-nvm:clear-all) (defsimpleprim :count :reporter clnl-nvm:count) -(defsimpleprim :crt :command clnl-nvm:create-turtles) +(defprim '(:crt :create-turtles) :command (lambda (num &optional fn) `(clnl-nvm:create-turtles ,num nil ,fn))) (defsimpleprim :die :command clnl-nvm:die) (defsimpleprim :display :command clnl-nvm:display) (defsimpleprim :fd :command clnl-nvm:forward) diff --git a/src/test/modeltests.lisp b/src/test/modeltests.lisp index aa9b22b..79ebc4b 100644 --- a/src/test/modeltests.lisp +++ b/src/test/modeltests.lisp @@ -86,3 +86,25 @@ to go end" "setup go" "2972B3EC1285BDA17656401001E1AE667FA7F5AF") + +(defmodelcommandtest "breeds 1" + "breed [wolves wolf] + +to setup + create-turtles 50 + create-turtles 50 [ fd 1 ] + create-wolves 50 + set-default-shape wolves \"sheep\" + create-wolves 50 [ fd 1 ] +end + +to go + ask turtles [ fd 1 ] + ask wolves [ fd 1 ] + ask turtles [ if 1 < count turtles-here [ fd 1 ] ] + ask wolves [ if 1 < count turtles-here [ fd 1 ] ] + ask turtles [ if 1 < count wolves-here [ fd 1 ] ] + ask wolves [ if 1 < count wolves-here [ fd 1 ] ] +end" + "setup go" + "2614B99F64ACFA2BD64D66B129C0A17F2150FADD") -- 2.25.1 From f011c771176fcb272939f01ddf31c1dd267990bf Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Fri, 13 May 2016 19:53:19 -0500 Subject: [PATCH 03/16] Code - procedures handle stop better --- src/main/main.lisp | 17 +++++++++-------- src/test/modeltests.lisp | 14 ++++++++++++++ 2 files changed, 23 insertions(+), 8 deletions(-) diff --git a/src/main/main.lisp b/src/main/main.lisp index 35a5961..5d8856e 100644 --- a/src/main/main.lisp +++ b/src/main/main.lisp @@ -115,14 +115,15 @@ DESCRIPTION: (defun create-proc-body (proc prims) `(,(intern (string-upcase (car proc)) *model-package*) () - ,@(cdr ; remove the progn, cuz it looks nicer - (clnl-transpiler:transpile (cadr proc) - (mapcar - (lambda (prim) - (if (getf prim :macro) ; The reason we do this is because with macros, we want to evaluate them in - ; this scope while preserving them for the generational purposes below - (append (list :macro (eval (getf prim :macro))) prim) - prim)) prims))))) + (clnl-nvm:with-stop-handler + ,@(cdr ; remove the progn, cuz it looks nicer + (clnl-transpiler:transpile (cadr proc) + (mapcar + (lambda (prim) + (if (getf prim :macro) ; The reason we do this is because with macros, we want to evaluate them in + ; this scope while preserving them for the generational purposes below + (append (list :macro (eval (getf prim :macro))) prim) + prim)) prims)))))) (defun model->single-form-lisp (model &key (seed 15) initialize-interface netlogo-callback) (multiple-value-bind diff --git a/src/test/modeltests.lisp b/src/test/modeltests.lisp index 79ebc4b..8f2d12a 100644 --- a/src/test/modeltests.lisp +++ b/src/test/modeltests.lisp @@ -108,3 +108,17 @@ to go end" "setup go" "2614B99F64ACFA2BD64D66B129C0A17F2150FADD") + +(defmodelcommandtest "procedures stop" + "to setup + create-turtles 5 + stop + create-turtles 5 +end + +to go + if 5 < count turtles [ stop ] + crt 1 +end" + "setup go go" + "438848EF35C6B0D28D50961072C70FCC02BB4FD8") -- 2.25.1 From 3ae0c35e27580b247652dff608dd8c4d29f16bff Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Fri, 13 May 2016 20:09:03 -0500 Subject: [PATCH 04/16] Prims - die halts execution --- src/main/nvm/nvm.lisp | 3 ++- src/test/simpletests.lisp | 3 +++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp index 0981332..c31640e 100644 --- a/src/main/nvm/nvm.lisp +++ b/src/main/nvm/nvm.lisp @@ -91,7 +91,8 @@ DESCRIPTION: See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#die" (when (not (turtle-p *self*)) (error "Gotta call die in turtle scope, dude (~A)" *self*)) (setf (turtle-who *self*) -1) - (setf *turtles* (remove *self* *turtles*))) + (setf *turtles* (remove *self* *turtles*)) + (error (make-condition 'stop))) (defun patches () "PATCHES => ALL-PATCHES diff --git a/src/test/simpletests.lisp b/src/test/simpletests.lisp index 9bf58d3..78293e0 100644 --- a/src/test/simpletests.lisp +++ b/src/test/simpletests.lisp @@ -114,6 +114,9 @@ (defsimplecommandtest "die 1" "crt 10 ask turtles [ die ]" "A665C1BF95E1F9CAAE9B9F8B2FBE3DAA45453136") +(defsimplecommandtest "die 2" "crt 10 ask turtles [ hatch 1 die hatch 1 ]" + "DFB46C61ACB9A24004FF26B04DCB0AC32E90AA36") + (defreportertestwithsetup "any? 3" "crt 10 ask turtles [ die ]" "any? turtles" "false" "A665C1BF95E1F9CAAE9B9F8B2FBE3DAA45453136") -- 2.25.1 From 807df6b6f160d82cc04ca02ce88d61ee58439ad1 Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Sat, 14 May 2016 01:30:49 -0500 Subject: [PATCH 05/16] Wolf sheep works in tests --- bin/runcmd.scala | 2 ++ src/main/clnl.asd | 2 +- src/main/code-parse.lisp | 2 +- src/main/main.lisp | 39 +++++++++++------------- src/main/nvm/agent.lisp | 6 ++++ src/main/nvm/base.lisp | 9 +++++- src/main/nvm/nvm.lisp | 64 ++++++++++++++++++++++----------------- src/main/nvm/utils.lisp | 7 +++-- src/main/transpile.lisp | 9 ++++-- src/test/main.lisp | 41 +++++++++++++++++++++++++ src/test/modeltests.lisp | 8 +++++ src/test/simpletests.lisp | 9 ++++++ 12 files changed, 140 insertions(+), 58 deletions(-) diff --git a/bin/runcmd.scala b/bin/runcmd.scala index b91ed4e..12e49a7 100755 --- a/bin/runcmd.scala +++ b/bin/runcmd.scala @@ -86,6 +86,8 @@ Polygon -7500403 true false 219 85 210 105 193 99 201 83 @#$#@#$#@ NetLogo 5.2.0""") +} else if (input.length > 3 && input(3).length > 0) { + workspace.openFromSource(url2String("file:" + input(3))) } else { workspace.openFromSource(url2String("file:resources/empty.nlogo")) } diff --git a/src/main/clnl.asd b/src/main/clnl.asd index 1f90141..c3ec27e 100644 --- a/src/main/clnl.asd +++ b/src/main/clnl.asd @@ -10,8 +10,8 @@ (:file "parse") (:file "code-parse") (:file "nvm/base") - (:file "nvm/agent") (:file "nvm/utils") + (:file "nvm/agent") (:file "nvm/nvm") (:file "nvm/topology") (:file "transpile") diff --git a/src/main/code-parse.lisp b/src/main/code-parse.lisp index 1cb6662..5fe98b8 100644 --- a/src/main/code-parse.lisp +++ b/src/main/code-parse.lisp @@ -67,7 +67,7 @@ DESCRIPTION: (let* ((*dynamic-prims* (append - (mapcar #'global->prim external-globals) + (mapcar #'global->prim (mapcar #'car external-globals)) (procedures->prims lexed-ast))) (parsed (parse-internal lexed-ast))) (values diff --git a/src/main/main.lisp b/src/main/main.lisp index 5d8856e..0997963 100644 --- a/src/main/main.lisp +++ b/src/main/main.lisp @@ -132,28 +132,23 @@ DESCRIPTION: (let ((globals (append - (clnl-model:widget-globals model) - (clnl-code-parser:globals code-ast)))) - `(prog () - ; First declare is in case we don't use it, it shows up in export correctly - ,@(when (and (> (length globals) 0) netlogo-callback) - `((declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals))))) - (let - ,(mapcar (lambda (pair) (list (intern (string-upcase (car pair)) *model-package*) (cadr pair))) globals) - ; We declare twice rather than once and doing a bunch of setfs - ,@(when (and (> (length globals) 0) netlogo-callback) - `((declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals))))) - (labels - ,(mapcar - (lambda (proc) (create-proc-body proc prims)) - (clnl-code-parser:procedures code-ast)) - (clnl-random:set-seed ,seed) - ,(create-world-call model globals code-ast) - ,@(when netlogo-callback - `((funcall ,netlogo-callback - (lambda (,(intern "NETLOGO-CODE" *model-package*)) - ,(netlogo-callback-body prims))))) - ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model)))))))))) + (clnl-code-parser:globals code-ast) + (clnl-model:widget-globals model)))) + `(progn + ,@(mapcar + (lambda (pair) `(defparameter ,(intern (string-upcase (car pair)) *model-package*) ,(cadr pair))) + globals) + (labels + ,(mapcar + (lambda (proc) (create-proc-body proc prims)) + (clnl-code-parser:procedures code-ast)) + (clnl-random:set-seed ,seed) + ,(create-world-call model globals code-ast) + ,@(when netlogo-callback + `((funcall ,netlogo-callback + (lambda (,(intern "NETLOGO-CODE" *model-package*)) + ,(netlogo-callback-body prims))))) + ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model))))))))) (setf (documentation 'model->single-form-lisp 'function) "MODEL->SINGLE-FORM-LISP MODEL &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK => FORM diff --git a/src/main/nvm/agent.lisp b/src/main/nvm/agent.lisp index 8e97ea0..e20efa2 100644 --- a/src/main/nvm/agent.lisp +++ b/src/main/nvm/agent.lisp @@ -38,6 +38,12 @@ DESCRIPTION: ; Don't want the setter for :who (defmethod agent-value-inner ((turtle turtle) (var (eql :who))) (turtle-who turtle)) +(defmethod agent-value-inner ((turtle turtle) (var (eql :pcolor))) + (patch-color (patch-at (turtle-xcor turtle) (turtle-ycor turtle)))) + +(defmethod set-agent-value-inner ((turtle turtle) (var (eql :pcolor)) new-val) + (setf (patch-color (patch-at (turtle-xcor turtle) (turtle-ycor turtle))) new-val)) + (defagent-value patch :pcolor patch-color) (defagent-value turtle :color) diff --git a/src/main/nvm/base.lisp b/src/main/nvm/base.lisp index 063dfb5..7fec1df 100644 --- a/src/main/nvm/base.lisp +++ b/src/main/nvm/base.lisp @@ -15,6 +15,7 @@ (defvar *breeds* nil) (define-condition stop nil nil) +(define-condition death nil nil) (defmacro with-stop-handler (&rest forms) "MACRO WITH-STOP-HANDLER &rest FORMS => HANDLED-FORM @@ -31,7 +32,13 @@ DESCRIPTION: :stop is returned." `(handler-case (progn ,@forms) (stop (s) (declare (ignore s)) :stop))) -(defstruct turtle who breed color heading xcor ycor (label "") (label-color 9.9d0) (size 1d0) shape own-vars) +(defmacro with-stop-and-death-handler (&rest forms) + `(handler-case + (progn ,@forms) + (stop (s) (declare (ignore s)) :stop) + (death (d) (declare (ignore d)) :death))) + +(defstruct turtle who breed color heading xcor ycor (label "") label-color size shape own-vars) (defstruct patch color xcor ycor own-vars turtles) (defun agentset-list (agentset) diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp index c31640e..5540cae 100644 --- a/src/main/nvm/nvm.lisp +++ b/src/main/nvm/nvm.lisp @@ -59,10 +59,13 @@ DESCRIPTION: :heading (if base-turtle (turtle-heading base-turtle) (coerce (clnl-random:next-int 360) 'double-float)) + :label-color (if base-turtle (turtle-label-color base-turtle) 9.9d0) + :size (if base-turtle (turtle-size base-turtle) 1d0) :breed breed :shape (breed-default-shape breed) :xcor (if base-turtle (turtle-xcor base-turtle) 0d0) - :ycor (if base-turtle (turtle-ycor base-turtle) 0d0)))) + :ycor (if base-turtle (turtle-ycor base-turtle) 0d0) + :own-vars (when base-turtle (copy-list (turtle-own-vars base-turtle)))))) (let ((patch (patch-at (turtle-xcor new-turtle) (turtle-ycor new-turtle)))) (setf (patch-turtles patch) (nconc (patch-turtles patch) (list new-turtle)))) @@ -92,7 +95,10 @@ DESCRIPTION: (when (not (turtle-p *self*)) (error "Gotta call die in turtle scope, dude (~A)" *self*)) (setf (turtle-who *self*) -1) (setf *turtles* (remove *self* *turtles*)) - (error (make-condition 'stop))) + (let + ((patch (patch-at (turtle-xcor *self*) (turtle-ycor *self*)))) + (setf (patch-turtles patch) (remove *self* (patch-turtles patch)))) + (error (make-condition 'death))) (defun patches () "PATCHES => ALL-PATCHES @@ -176,9 +182,10 @@ DESCRIPTION: (loop :for agent := (funcall iter) :while agent - :do (let ((*myself* *self*) (*self* agent)) (with-stop-handler (funcall fn)))))) + :do (when (not (and (turtle-p agent) (= -1 (turtle-who agent)))) + (let ((*myself* *self*) (*self* agent)) (with-stop-and-death-handler (funcall fn))))))) ((agent-p agent-or-agentset) - (let ((*myself* *self*) (*self* agent-or-agentset)) (with-stop-handler (funcall fn)))) + (let ((*myself* *self*) (*self* agent-or-agentset)) (with-stop-and-death-handler (funcall fn)))) (t (error "Ask requires an agentset or agent but got: ~A" agent-or-agentset)))) @@ -313,13 +320,14 @@ DESCRIPTION: ((copy (copy-list agentset-list)) (i 0) (agent nil)) - (flet + (labels ((fetch () (let ((idx (when (< i (1- (length copy))) (+ i (clnl-random:next-int (- (length copy) i)))))) (when idx (setf agent (nth idx copy))) (when idx (setf (nth idx copy) (nth i copy))) - (incf i)))) + (incf i) + (when (and (<= i (length copy)) (turtle-p agent) (= -1 (turtle-who agent))) (fetch))))) (fetch) ; we pre-fetch because netlogo does, rng sync hype! (lambda () (cond @@ -843,24 +851,26 @@ DESCRIPTION: This is useful for serializing the current state of the engine in order to compare against NetLogo or to reimport later. Contains everything needed to boot up a NetLogo instance in the exact same state." - (format nil "~{~A~%~}" - (list - (format nil "~S" "RANDOM STATE") - (format nil "~S" (clnl-random:export)) - "" - (format nil "~S" "GLOBALS") - (format nil "~A~A~{\"~A\"~^,~}" - "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\"," - "\"nextIndex\",\"directed-links\",\"ticks\"," - (mapcar #'string-downcase (mapcar #'car *globals*))) - (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"~A\"~{,\"~A\"~}" - (min-pxcor) (max-pxcor) (min-pycor) (max-pycor) *current-id* (dump-object (or *ticks* -1d0)) - (mapcar #'dump-object (mapcar #'funcall (mapcar #'cadr *globals*)))) - "" - (format nil "~{~A~^~%~}" (export-turtles)) - "" - (format nil "~{~A~^~%~}" (export-patches)) - "" - (format nil "~S" "LINKS") - "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\"" - ""))) + (let + ((ordered-globals (sort (copy-list *globals*) #'string< :key (lambda (global) (symbol-name (car global)))))) + (format nil "~{~A~%~}" + (list + (format nil "~S" "RANDOM STATE") + (format nil "~S" (clnl-random:export)) + "" + (format nil "~S" "GLOBALS") + (format nil "~A~A~{\"~A\"~^,~}" + "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\"," + "\"nextIndex\",\"directed-links\",\"ticks\"," + (mapcar #'string-downcase (mapcar #'car ordered-globals))) + (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"~A\"~{,\"~A\"~}" + (min-pxcor) (max-pxcor) (min-pycor) (max-pycor) *current-id* (dump-object (or *ticks* -1d0)) + (mapcar #'dump-object (mapcar #'funcall (mapcar #'cadr ordered-globals)))) + "" + (format nil "~{~A~^~%~}" (export-turtles)) + "" + (format nil "~{~A~^~%~}" (export-patches)) + "" + (format nil "~S" "LINKS") + "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\"" + "")))) diff --git a/src/main/nvm/utils.lisp b/src/main/nvm/utils.lisp index f95fb7f..0a5f604 100644 --- a/src/main/nvm/utils.lisp +++ b/src/main/nvm/utils.lisp @@ -39,12 +39,13 @@ (defmacro with-patch-update (turtle &rest forms) (let - ((patch (gensym)) (new-patch (gensym))) + ((patch (gensym)) (new-patch (gensym)) (retn (gensym))) `(let ((,patch (patch-at (turtle-xcor ,turtle) (turtle-ycor ,turtle))) - (retn (progn ,@forms))) + (,retn (progn ,@forms))) (let ((,new-patch (patch-at (turtle-xcor ,turtle) (turtle-ycor ,turtle)))) (when (not (eql ,patch ,new-patch)) (setf (patch-turtles ,patch) (remove ,turtle (patch-turtles ,patch))) - (setf (patch-turtles ,new-patch) (nconc (patch-turtles ,new-patch) (list ,turtle)))))))) + (setf (patch-turtles ,new-patch) (nconc (patch-turtles ,new-patch) (list ,turtle)))) + ,retn)))) diff --git a/src/main/transpile.lisp b/src/main/transpile.lisp index 91af23a..956b226 100644 --- a/src/main/transpile.lisp +++ b/src/main/transpile.lisp @@ -196,9 +196,12 @@ DESCRIPTION: (defprim :if :command (lambda (pred a) `(when ,pred ,@(make-command-block-inline a)))) (defprim '(:ifelse :if-else) :command (lambda (pred a b) - `(if ,pred - ,@(make-command-block-inline a) - ,@(make-command-block-inline b)))) + (let + ((then (make-command-block-inline a)) + (else (make-command-block-inline b))) + `(if ,pred + ,@(if (= (length then) 1) then `((progn ,@then))) + ,@(if (= (length else) 1) else `((progn ,@else))))))) (defagentvalueprim :label) (defagentvalueprim :label-color) diff --git a/src/test/main.lisp b/src/test/main.lisp index e02a5d4..ca65797 100644 --- a/src/test/main.lisp +++ b/src/test/main.lisp @@ -166,6 +166,47 @@ GRAPHICS-WINDOW~%210~%10~%649~%470~%-1~%-1~%13.0~%1~%10~%1~%1~%1~%0~%1~%1~%1~%-1 (defmacro defmodelreportertest (name model commands reporter value checksum) `(defmodeltest (format nil "Model Reporter - ~A" ,name) ,model ,commands ,reporter ,value ,checksum)) +(defmacro defmodelfiletest (name file commands checksum) + `(defsimpletest + ,(format nil "File Model - ~A" name) + (lambda () + (let + ((model (with-open-file (str ,file) (clnl-model:read-from-nlogo str)))) + (and + (let + ((callback nil)) + (declaim (sb-ext:muffle-conditions cl:warning)) + (eval (clnl:model->single-form-lisp model :netlogo-callback (lambda (f) (setf callback f)))) + (when ,commands (funcall callback ,commands)) + (checksum= ,checksum (checksum-world))) + (let* + ((pkg (make-package (gensym))) + (clnl:*model-package* pkg) + (prev-package *package*)) + (eval + (cons + 'progn + (clnl:model->multi-form-lisp model (intern "BOOT-ME" pkg) + :netlogo-callback-fn (intern "NETLOGO-CALLBACK" pkg)))) + (eval `(in-package ,(package-name prev-package))) + (funcall (symbol-function (intern "BOOT-ME" pkg))) + (when ,commands (funcall (symbol-function (intern "NETLOGO-CALLBACK" pkg)) ,commands)) + (checksum= ,checksum (checksum-world)))))) + (lambda () + (let + ((callback nil)) + (declaim (sb-ext:muffle-conditions cl:warning)) + (eval + (clnl:model->single-form-lisp + (with-open-file (str ,file) (clnl-model:read-from-nlogo str)) + :netlogo-callback (lambda (f) (setf callback f)))) + (when ,commands (funcall callback ,commands)) + (format nil "~A~A" + (clnl-nvm:export-world) + (checksum-world)))) + "bin/runcmd.scala" + (format nil "~A@#$#@#$#@@#$#@#$#@@#$#@#$#@~A" ,commands ,file))) + (defmacro defviewtest (name commands checksum) `(defsimpletest (format nil "Simple View - ~A" ,name) diff --git a/src/test/modeltests.lisp b/src/test/modeltests.lisp index 8f2d12a..144b549 100644 --- a/src/test/modeltests.lisp +++ b/src/test/modeltests.lisp @@ -122,3 +122,11 @@ to go end" "setup go go" "438848EF35C6B0D28D50961072C70FCC02BB4FD8") + +(defmodelfiletest "Wolf Sheep 1" "resources/models/Wolf Sheep Predation.nlogo" + "setup go go go go go go go go go go go go go go" + "9777CCF18935E52D8380C9C6DC02BFFBEE1F1149") + +(defmodelfiletest "Wolf Sheep 2" "resources/models/Wolf Sheep Predation.nlogo" + "set grass? not grass? setup go go go go go go go go go go go go go go" + "FC38F01DC0058C5EFF93F2228535ED7C616ECFF0") diff --git a/src/test/simpletests.lisp b/src/test/simpletests.lisp index 78293e0..aa6a309 100644 --- a/src/test/simpletests.lisp +++ b/src/test/simpletests.lisp @@ -117,6 +117,9 @@ (defsimplecommandtest "die 2" "crt 10 ask turtles [ hatch 1 die hatch 1 ]" "DFB46C61ACB9A24004FF26B04DCB0AC32E90AA36") +(defsimplecommandtest "die 3" "crt 5 ask turtles [ ask one-of turtles-here [ die ] hatch 1 ]" + "6D3B8351E71C03E479706C22172F6FACD2C558CE") + (defreportertestwithsetup "any? 3" "crt 10 ask turtles [ die ]" "any? turtles" "false" "A665C1BF95E1F9CAAE9B9F8B2FBE3DAA45453136") @@ -144,6 +147,12 @@ (defsimplecommandtest "ifelse 2" "ifelse 5 = 4 [ crt 10 ] [ crt 5 ] if-else 5 = 4 [ crt 10 ] [ crt 5 ]" "A925E39EC022967568D238D31F70F0A375024A89") +(defsimplecommandtest "ifelse 3" "ifelse 4 = 4 [ crt 5 crt 5 ] [ crt 10 crt 10 ]" + "A925E39EC022967568D238D31F70F0A375024A89") + +(defsimplecommandtest "ifelse 4" "ifelse 4 = 5 [ crt 5 crt 5 ] [ crt 10 crt 10 ]" + "2CF70DC9135754E77B64422C10E947E776E731E6") + (defsimplecommandtest "not 1" "if not (5 = 5) [ crt 10 ]" "E1DE30F072D785E0D0B59F28B0F7853E3D3E0D8B") -- 2.25.1 From cca1c12f7351ff2414bfd582ecb2cad590aa9b51 Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Sat, 14 May 2016 21:28:10 -0500 Subject: [PATCH 06/16] Extension loading - CLI Extension loaded by default --- bin/all.lisp | 6 ++- src/main/clnl.asd | 1 + src/main/code-parse.lisp | 3 +- src/main/extensions.lisp | 49 +++++++++++++++++++ src/main/extensions/cli/cli.lisp | 13 +++++ .../extensions/cli/clnl-extension-cli.asd | 5 ++ src/main/extensions/cli/package.lisp | 15 ++++++ src/main/package.lisp | 16 ++++++ 8 files changed, 106 insertions(+), 2 deletions(-) create mode 100644 src/main/extensions.lisp create mode 100644 src/main/extensions/cli/cli.lisp create mode 100644 src/main/extensions/cli/clnl-extension-cli.asd create mode 100644 src/main/extensions/cli/package.lisp diff --git a/bin/all.lisp b/bin/all.lisp index fb64370..eca1162 100644 --- a/bin/all.lisp +++ b/bin/all.lisp @@ -3,6 +3,7 @@ (asdf:initialize-source-registry `(:source-registry (:tree ,(car (directory "src"))) :INHERIT-CONFIGURATION)) (asdf:load-system :clnl) (asdf:load-system :clnl-test) +(asdf:load-system :clnl-extension-cli) #-travis(asdf:load-system :style-checker) #-travis(asdf:load-system :docgen) @@ -21,7 +22,10 @@ (when (not (find-package :docgen)) (asdf:load-system :docgen)) (format t "~%~c[1;33mChecking Docs~c[0m~%" #\Esc #\Esc) (when (not (docgen:pretty-print-validate-packages - :clnl :clnl-parser :clnl-random :clnl-transpiler :clnl-nvm :clnl-lexer :clnl-interface :clnl-cli :clnl-model :clnl-code-parser)) + :clnl :clnl-parser :clnl-random :clnl-transpiler :clnl-nvm + :clnl-lexer :clnl-interface :clnl-cli :clnl-model :clnl-code-parser + :clnl-extensions + :clnl-extension-cli)) (format t "~c[1;31mFailed doc check!~c[0m~%" #\Esc #\Esc) (sb-ext:exit :code 1)) (format t "~c[1;32m- Doc Check Passed!~c[0m~%" #\Esc #\Esc) diff --git a/src/main/clnl.asd b/src/main/clnl.asd index c3ec27e..f66dbb6 100644 --- a/src/main/clnl.asd +++ b/src/main/clnl.asd @@ -5,6 +5,7 @@ :author "Frank Duncan (frank@kank.com)" :components ((:file "package") (:file "base") + (:file "extensions") (:file "model") (:file "lex") (:file "parse") diff --git a/src/main/code-parse.lisp b/src/main/code-parse.lisp index 5fe98b8..4e75407 100644 --- a/src/main/code-parse.lisp +++ b/src/main/code-parse.lisp @@ -68,7 +68,8 @@ DESCRIPTION: ((*dynamic-prims* (append (mapcar #'global->prim (mapcar #'car external-globals)) - (procedures->prims lexed-ast))) + (procedures->prims lexed-ast) + (clnl-extensions:load-extension :cli))) (parsed (parse-internal lexed-ast))) (values (butlast parsed) diff --git a/src/main/extensions.lisp b/src/main/extensions.lisp new file mode 100644 index 0000000..6755d50 --- /dev/null +++ b/src/main/extensions.lisp @@ -0,0 +1,49 @@ +(in-package #:clnl-extensions) + +(defun load-extension (extension) + "LOAD-EXTENSION EXTENSION => PRIMS + +ARGUMENTS AND VALUES: + + EXTENSION: A symbol + PRIMS: Primitives that can be sent to the parser and transpiler + +DESCRIPTION: + + LOAD-EXTENSION takes an EXTENSION and does the work to load the asdf package, + as well as munge the prims from extension style prims to things to be used by + the CLNL compiler stack. + + It returns those PRIMS after checking that all the pieces are there to not + break the runtime." + (let* + ((name (intern (format nil "CLNL-EXTENSION-~A" (string-upcase extension)) :keyword))) + (asdf:load-system name) + (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))))))) diff --git a/src/main/extensions/cli/cli.lisp b/src/main/extensions/cli/cli.lisp new file mode 100644 index 0000000..843cf01 --- /dev/null +++ b/src/main/extensions/cli/cli.lisp @@ -0,0 +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." + nil) diff --git a/src/main/extensions/cli/clnl-extension-cli.asd b/src/main/extensions/cli/clnl-extension-cli.asd new file mode 100644 index 0000000..65e8dd8 --- /dev/null +++ b/src/main/extensions/cli/clnl-extension-cli.asd @@ -0,0 +1,5 @@ +(asdf:defsystem clnl-extension-cli + :name "CLI Extension" + :maintainer "Frank Duncan (frank@kank.com)" + :author "Frank Duncan (frank@kank.com)" + :components ((:file "package") (:file "cli"))) diff --git a/src/main/extensions/cli/package.lisp b/src/main/extensions/cli/package.lisp new file mode 100644 index 0000000..00873dc --- /dev/null +++ b/src/main/extensions/cli/package.lisp @@ -0,0 +1,15 @@ +(defpackage #:clnl-extension-cli + (:use :common-lisp) + (:export #:prims) + (:documentation + "CLI Extension + +The CLI Extension provides prims for interacting with the interface from the +commandline. It is a special extension in that it is the only one that without +a prefix being appended to the prims. + +It uses the available functions made public through normal clnl packages to +offer command line operations to control the clnl program. Because it is +an extension, all primitives are also available to any NetLogo programs +running in CLNL. As there is no special case control mechanism in the original +NetLogo, the CLI extension represents a departure from classic NetLogo.")) diff --git a/src/main/package.lisp b/src/main/package.lisp index 6db65fb..443f85d 100644 --- a/src/main/package.lisp +++ b/src/main/package.lisp @@ -141,6 +141,22 @@ all of the sections, and subsections held within. This package houses not only the code to read and write .nlogo files, but also the living state of the model as clnl runs.")) +(defpackage #:clnl-extensions + (:use :common-lisp) + (:export #:load-extension) + (:documentation + "CLNL Extensions + +The loading and handling of extensions to CLNL modeled after the way that +NetLogo handles extensions. + +Extensions are defined as Common Lisp systems (under asdf) that export +the primitive PRIMS. The name of the asdf system is defined to be the +name of the extension prepended by CLNL-EXTENSION-, such that for a hypothetical +extension ARRAY, the name of the asdf system would be CLNL-EXTENSION-ARRAY +and found through conventional asdf means. The package that the required +functions are symbols in should be the same as the asdf system.")) + (defpackage #:clnl-default-model-package (:use :common-lisp) (:shadow #:go)) -- 2.25.1 From 057ed8dbc95f13245afd62e4f4769fc29f42b0c8 Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Sat, 14 May 2016 21:48:41 -0500 Subject: [PATCH 07/16] CLI Extension - :q --- src/main/cli.lisp | 3 +-- src/main/extensions/cli/cli.lisp | 7 ++++++- src/main/main.lisp | 8 ++++++-- 3 files changed, 13 insertions(+), 5 deletions(-) diff --git a/src/main/cli.lisp b/src/main/cli.lisp index fe895e2..1aeb746 100644 --- a/src/main/cli.lisp +++ b/src/main/cli.lisp @@ -23,7 +23,6 @@ DESCRIPTION: (loop :for str := (cffi:with-foreign-pointer-as-string (str 255) (wgetnstr *cli* str 255)) :while str - :while (and (string/= str "q") (string/= str "Q")) :do (print-command-and-response str (execute str))) (endwin) (sb-ext:exit :abort t)) @@ -85,7 +84,7 @@ DESCRIPTION: implementation of NetLogo. You can enter in various netlogo commands below, - or use q to quit the program. + or use :q to quit the program. See http://github.com/frankduncan/clnl for more information about CLNL and to keep apprised of diff --git a/src/main/extensions/cli/cli.lisp b/src/main/extensions/cli/cli.lisp index 843cf01..8453391 100644 --- a/src/main/extensions/cli/cli.lisp +++ b/src/main/extensions/cli/cli.lisp @@ -10,4 +10,9 @@ ARGUMENTS AND VALUES: DESCRIPTION: PRIMS returns the primitives used in the CLI extension." - nil) + (list + (list :name :q :type :command :func #'shut-down))) + +(defun shut-down () + (cl-charms/low-level:endwin) + (sb-ext:exit :abort t)) diff --git a/src/main/main.lisp b/src/main/main.lisp index 0997963..48c3c58 100644 --- a/src/main/main.lisp +++ b/src/main/main.lisp @@ -29,6 +29,8 @@ DESCRIPTION: (sb-thread:make-thread #'clnl-cli:run) (clnl-interface:run)) +(defvar *callback* nil) + (defun boot (&optional file headless-mode) "BOOT &optional FILE HEADLESS-MODE => RESULT @@ -51,7 +53,8 @@ DESCRIPTION: ((netlogoed-lisp (model->single-form-lisp (if file (with-open-file (str file) (clnl-model:read-from-nlogo str)) (clnl-model:default-model)) - :initialize-interface (not headless-mode))) + :initialize-interface (not headless-mode) + :netlogo-callback (lambda (f) (setf *callback* f)))) (*package* *model-package*)) (eval netlogoed-lisp))) @@ -67,7 +70,8 @@ DESCRIPTION: RUN-COMMANDS will take NetLogo commands, put them through the various stages need to turn them into Common Lisp code, and run it." - (clnl-nvm:with-stop-handler (eval (clnl-transpiler:transpile (clnl-parser:parse (clnl-lexer:lex cmds)))))) + (clnl-nvm:with-stop-handler + (funcall *callback* cmds))) (defun run-reporter (reporter) "RUN-REPORTER REPORTER => RESULT -- 2.25.1 From b25736698f7f7f9670f8e2408055556c4dd99ef0 Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Sun, 15 May 2016 12:19:22 -0500 Subject: [PATCH 08/16] Parser - Add :token argument type --- src/main/parse.lisp | 25 ++++++++++++++++++++++++- src/main/transpile.lisp | 1 + 2 files changed, 25 insertions(+), 1 deletion(-) diff --git a/src/main/parse.lisp b/src/main/parse.lisp index e3daa08..6197d30 100644 --- a/src/main/parse.lisp +++ b/src/main/parse.lisp @@ -121,6 +121,17 @@ DESCRIPTION: :prev-item (coerce (car lexed-ast) 'double-float) :prev-remaining-arg (car remaining-args) :remaining-args (cdr remaining-args))) + ((and remaining-args + (or + (eql :token (car remaining-args)) + (and + (listp (car remaining-args)) + (find :token (car remaining-args)) + (symbolp (car lexed-ast))))) + (parse-internal (cdr lexed-ast) + :prev-item (car lexed-ast) + :prev-remaining-arg (car remaining-args) + :remaining-args (cdr remaining-args))) ((eql (intern "(" :keyword) (car lexed-ast)) (parse-parened-expr (cdr lexed-ast) remaining-args)) ((eql (intern ")" :keyword) (car lexed-ast)) (error "Closing parens has no opening parens")) ((eql :let (car lexed-ast)) (parse-let (cdr lexed-ast) remaining-args)) @@ -136,7 +147,7 @@ DESCRIPTION: (let* ((half-parsed-remainder (parse-internal (cdr lexed-ast) :remaining-args (list t :done-with-args)))) (let - ((*dynamic-prims* (cons (list :name (car lexed-ast)) *dynamic-prims*))) + ((*dynamic-prims* (cons (list :name (car lexed-ast) :precedence 20) *dynamic-prims*))) (parse-internal (cdr half-parsed-remainder) :remaining-args (cdr remaining-args) @@ -170,6 +181,15 @@ DESCRIPTION: following-args))))))) (defun parse-prim (prim lexed-ast prev-item prev-remaining-arg remaining-args) + (when (not (prim-precedence prim)) + (error "Prim must have a precedence! ~A" prim)) + (when (and (prim-is-infix prim) (eql :token (car (prim-args prim)))) + (error "Can't have a prim that wants a token in the first position while being infix: ~A" prim)) + (when + (and + (< (prim-precedence prim) 20) + (find-if (lambda (arg) (or (eql :token arg) (and (listp arg) (find :token arg)))) (prim-args prim))) + (error "Can't have a prim that wants a token and has a precedence of less than 20: ~A" prim)) (let* ((args (if (prim-is-infix prim) (cdr (prim-args prim)) (prim-args prim))) (half-parsed-remainder (parse-internal (cdr lexed-ast) :remaining-args (append args (list :done-with-args)))) @@ -198,6 +218,8 @@ DESCRIPTION: (defun help-arg (arg arg-type) (cond ((not arg-type) arg) + ((eql arg-type :token) (list :arg (list :token arg))) + ((and (listp arg-type) (find :token arg-type) (symbolp arg)) (list :arg (list :token arg))) ((eql arg-type :command-block) (if (not (and (consp arg) (eql 'block (car arg)))) (error "Required a block, but found a ~A" arg) @@ -279,6 +301,7 @@ DESCRIPTION: ; - :agentset ; - :command-block ; - :boolean +; - :token (suspends evaluation) ; - t - any type ; ; After the arguments, :infix denotes that it's an :infix operator diff --git a/src/main/transpile.lisp b/src/main/transpile.lisp index 956b226..e78208d 100644 --- a/src/main/transpile.lisp +++ b/src/main/transpile.lisp @@ -143,6 +143,7 @@ DESCRIPTION: ((eql :command-block (car reporter)) (transpile-command-block reporter)) ((eql :list-literal (car reporter)) (cons 'list (mapcar #'transpile-reporter (cdr reporter)))) ((eql :reporter-block (car reporter)) (transpile-reporter-block reporter)) + ((eql :token (car reporter)) (cadr reporter)) ((and (symbolp (car reporter)) (find (car reporter) *local-variables*)) (intern (symbol-name (car reporter)) clnl:*model-package*)) ((not (find-prim (car reporter))) (error "Couldn't find the reporter for ~S" (car reporter))) -- 2.25.1 From 92fae8cd60b7c5a66098d6e6044803c4a8a8c17a Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Sun, 15 May 2016 12:19:38 -0500 Subject: [PATCH 09/16] CLI Extension - Add load, help --- src/main/cli.lisp | 2 +- src/main/extensions/cli/cli.lisp | 19 ++++++++++++++++++- 2 files changed, 19 insertions(+), 2 deletions(-) diff --git a/src/main/cli.lisp b/src/main/cli.lisp index 1aeb746..4dcc8f0 100644 --- a/src/main/cli.lisp +++ b/src/main/cli.lisp @@ -31,7 +31,7 @@ DESCRIPTION: (handler-case (with-output-to-string (*standard-output*) (clnl:run-commands str)) - (error (e) (format nil "Ok, something went wrong: ~A" e)))) + (error (e) (format nil "Ok, something went wrong: ~A~%Try :help" e)))) ; for ui, we need to do at a minimum: ; - cli, first pass, read things in, bottom of the screen, diff --git a/src/main/extensions/cli/cli.lisp b/src/main/extensions/cli/cli.lisp index 8453391..6d24da7 100644 --- a/src/main/extensions/cli/cli.lisp +++ b/src/main/extensions/cli/cli.lisp @@ -11,8 +11,25 @@ DESCRIPTION: PRIMS returns the primitives used in the CLI extension." (list - (list :name :q :type :command :func #'shut-down))) + (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))) (defun shut-down () (cl-charms/low-level:endwin) (sb-ext:exit :abort t)) + +(defun load-file (file) + (clnl:boot file)) + +(defun help (&optional token) + (format t + (if (not token) + "Placeholder help facility, try <:help :q> or <:help :load> for information about the commands we accept" + (case token + (:|:Q| ":q quits out of clnl") + (:|:LOAD| + (concatenate 'string + ":load loads up a model into the current clnl instance." + " Try :load \"resources/models/Wolf Sheep Predation.nlogo\"")) + (t (format nil "Don't have help for ~S" token)))))) -- 2.25.1 From 0d6408c2ba880e77c422c1d1b022b3046c9c0a24 Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Sun, 15 May 2016 14:58:35 -0500 Subject: [PATCH 10/16] Interface - add resize capabilities --- bin/diagnose-test | 1 + bin/diagnose-view-test | 1 + src/main/interface.lisp | 43 ++++++++++++++++++++++++----------------- src/main/main.lisp | 1 - src/main/model.lisp | 5 +++-- src/test/viewtests.lisp | 12 ++++++------ 6 files changed, 36 insertions(+), 27 deletions(-) diff --git a/bin/diagnose-test b/bin/diagnose-test index 52d7c4c..1c99a31 100755 --- a/bin/diagnose-test +++ b/bin/diagnose-test @@ -10,6 +10,7 @@ sbcl --eval "(asdf:load-system :clnl-test)" --eval "(quit)" &> /dev/null runtestfn() { sbcl --noinform --disable-ldb --lose-on-corruption --end-runtime-options \ + --eval "(asdf:initialize-source-registry \`(:source-registry (:tree ,(car (directory \"src\"))) :INHERIT-CONFIGURATION))" \ --eval "(asdf:load-system :clnl-test)" \ --eval "(clnl-test::$1 \"$TEST\")" \ --eval "(quit)" 2> /dev/null | sed -n '/^----$/,$p' | tail -n +2 diff --git a/bin/diagnose-view-test b/bin/diagnose-view-test index 73dd422..efa99f3 100755 --- a/bin/diagnose-view-test +++ b/bin/diagnose-view-test @@ -11,6 +11,7 @@ sbcl --eval "(asdf:load-system :clnl-test)" --eval "(quit)" &> /dev/null runtestfn() { sbcl \ --noinform --disable-ldb --lose-on-corruption --end-runtime-options \ + --eval "(asdf:initialize-source-registry \`(:source-registry (:tree ,(car (directory \"src\"))) :INHERIT-CONFIGURATION))" \ --eval "(asdf:load-system :clnl-test)" \ --eval "(clnl-test::$1 \"$TEST\")" \ --eval "(quit)" 2> /dev/null | sed -n '/^----$/,$p' | tail -n +2 diff --git a/src/main/interface.lisp b/src/main/interface.lisp index 6033740..95e2911 100644 --- a/src/main/interface.lisp +++ b/src/main/interface.lisp @@ -1,7 +1,5 @@ (in-package #:clnl-interface) -(defvar *patch-size* 13d0) - (defvar *turtle-list* nil) (defvar *patch-list* nil) @@ -38,7 +36,12 @@ (gl:clear :color-buffer-bit :depth-buffer-bit) (gl:matrix-mode :projection) (gl:load-identity) - (gl:ortho -71 71 -71 71 1 5000) + (gl:ortho + (floor (* (- (getf *dimensions* :xmin) 0.5) (patch-size))) + (floor (* (+ (getf *dimensions* :xmax) 0.5) (patch-size))) + (floor (* (- (getf *dimensions* :ymin) 0.5) (patch-size))) + (floor (* (+ (getf *dimensions* :ymax) 0.5) (patch-size))) + 0 5000) (gl:matrix-mode :modelview) (gl:load-identity) (destructuring-bind (turtles patches) (clnl-nvm:current-state) @@ -48,9 +51,9 @@ ((color (nl-color->rgb (getf patch :color)))) (gl:color (car color) (cadr color) (caddr color))) (gl:with-pushed-matrix - (gl:translate (* (getf patch :xcor) *patch-size*) (* (getf patch :ycor) *patch-size*) 0) - (gl:translate (floor (* -.5d0 *patch-size*)) (floor (* -.5d0 *patch-size*)) 0) - (gl:scale *patch-size* *patch-size* 1) + (gl:translate (* (getf patch :xcor) (patch-size)) (* (getf patch :ycor) (patch-size)) 0) + (gl:translate (floor (* -.5d0 (patch-size))) (floor (* -.5d0 (patch-size))) 0) + (gl:scale (patch-size) (patch-size) 1) (gl:call-list *patch-list*))) patches) (mapcar @@ -61,10 +64,10 @@ (mapcar (lambda (x-modification y-modification) (gl:with-pushed-matrix - (gl:translate (* (getf turtle :xcor) *patch-size*) (* (getf turtle :ycor) *patch-size*) 0) + (gl:translate (* (getf turtle :xcor) (patch-size)) (* (getf turtle :ycor) (patch-size)) 0) (gl:translate x-modification y-modification 0) (gl:rotate (getf turtle :heading) 0 0 -1) - (gl:scale *patch-size* *patch-size* 1) + (gl:scale (patch-size) (patch-size) 1) (gl:scale (getf turtle :size) (getf turtle :size) 1) (gl:call-list *turtle-list*))) (list 0 (1- (world-width-in-pixels)) (- (1- (world-width-in-pixels))) 0 0) @@ -95,8 +98,8 @@ (setf *turtle-list* (gl:gen-lists 1)) (gl:with-new-list (*turtle-list* :compile) (gl:rotate 180 0 0 -1) - (gl:scale (/ 1d0 300d0) (/ 1d0 300d0) 1) - (gl:translate -150 -150 -4.0) + (gl:scale (/ 1 300d0) (/ 1d0 300d0) 1) + (gl:translate -150 -150 -0.0) (gl:begin :polygon) (gl:vertex 150 5 0) (gl:vertex 40 250 0) @@ -107,7 +110,6 @@ (defun set-patch-list () (setf *patch-list* (gl:gen-lists 1)) (gl:with-new-list (*patch-list* :compile) - (gl:translate 0d0 0d0 -4.0) (gl:begin :polygon) (gl:vertex 0 0 0) (gl:vertex 0 1 0) @@ -118,7 +120,7 @@ (defun initialize (&key dims) "INITIALIZE &key DIMS => RESULT - DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX) + DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX :patch-size PATCH-SIZE) ARGUMENTS AND VALUES: @@ -127,6 +129,7 @@ ARGUMENTS AND VALUES: XMAX: An integer representing the maximum patch coord in X YMIN: An integer representing the minimum patch coord in Y YMAX: An integer representing the maximum patch coord in Y + PATCH-SIZE: A double representing the size of the patches in pixels DESCRIPTION: @@ -134,7 +137,9 @@ DESCRIPTION: the interface lives. From here, one can go into headless or running mode, but for certain things this interface will still need to act, and also allows for bringing up and taking down of visual elements." - (setf *dimensions* dims)) + (setf *dimensions* dims) + (when *glut-window-opened* + (cl-glut:reshape-window (world-width-in-pixels) (world-height-in-pixels)))) (defun run () "RUN => RESULT @@ -169,11 +174,13 @@ DESCRIPTION: (set-patch-list) (cl-glut:main-loop))) +(defun patch-size () (getf *dimensions* :patch-size)) + (defun world-width-in-pixels () - (floor (* *patch-size* (1+ (- (getf *dimensions* :xmax) (getf *dimensions* :xmin)))))) + (floor (* (patch-size) (1+ (- (getf *dimensions* :xmax) (getf *dimensions* :xmin)))))) (defun world-height-in-pixels () - (floor (* *patch-size* (1+ (- (getf *dimensions* :ymax) (getf *dimensions* :ymin)))))) + (floor (* (patch-size) (1+ (- (getf *dimensions* :ymax) (getf *dimensions* :ymin)))))) (defun export-view () "EXPORT-VIEW => IMAGE-DATA @@ -205,12 +212,12 @@ DESCRIPTION: ((fbo (first (gl:gen-framebuffers 1))) (render-buf (first (gl:gen-renderbuffers 1))) ;(width - ; (floor (* *patch-size* (1+ (- + ; (floor (* (patch-size) (1+ (- ; (getf *dimensions* :ymax) ; (getf *dimensions* :ymin)))))) ;(height - ; (floor (* *patch-size* (1+ (- (getf *world-dims* :xmax) (getf *world-dims* :xmin)))))) - ; (floor (* *patch-size* (1+ (- + ; (floor (* (patch-size) (1+ (- (getf *world-dims* :xmax) (getf *world-dims* :xmin)))))) + ; (floor (* (patch-size) (1+ (- ; (getf *dimensions* :xmax) ; (getf *dimensions* :xmin))))) (width (world-width-in-pixels)) ; Hard coded for now, yay v1 (if you see this comment in a year, please cry for me) diff --git a/src/main/main.lisp b/src/main/main.lisp index 48c3c58..5bb9361 100644 --- a/src/main/main.lisp +++ b/src/main/main.lisp @@ -24,7 +24,6 @@ ARGUMENTS AND VALUES: DESCRIPTION: RUN starts up the CLNL system." - (boot) (sb-thread:make-thread #'clnl-cli:run) (clnl-interface:run)) diff --git a/src/main/model.lisp b/src/main/model.lisp index 022a658..5e0dde7 100644 --- a/src/main/model.lisp +++ b/src/main/model.lisp @@ -29,7 +29,7 @@ DESCRIPTION: (make-model :code "" :interface (list - (make-view :min-pxcor -5 :max-pxcor 5 :min-pycor -5 :max-pycor 5)))) + (make-view :min-pxcor -5 :max-pxcor 5 :min-pycor -5 :max-pycor 5 :patch-size 13d0)))) (defun read-from-nlogo (str) "READ-FROM-NLOGO STR => MODEL @@ -221,7 +221,8 @@ DESCRIPTION: :xmin (view-min-pxcor view) :xmax (view-max-pxcor view) :ymin (view-min-pycor view) - :ymax (view-max-pycor view)))) + :ymax (view-max-pycor view) + :patch-size (view-patch-size view)))) (defun widget-globals (model) "WIDGET-GLOBALS MODEL => GLOBALS diff --git a/src/test/viewtests.lisp b/src/test/viewtests.lisp index 9135e47..3455b28 100644 --- a/src/test/viewtests.lisp +++ b/src/test/viewtests.lisp @@ -4,25 +4,25 @@ "62B8B468D5ED63CDFB567C984E0CAB53DBD03CEB") (defviewtest "Basic 1" "crt 1" - "67F7062D7485C3A31D0065549AB8BED71A48BFEE") + "BB7774BC721E16BD92B18228BBBAC8D7BAAA6271") (defviewtest "Basic 2" "crt 10 ask turtles [ fd 1 ]" - '("FC3B914602A7F41C5044B7A605DFF36D866B3A7F" "E09857180035872901B8BE27FE5470FD3D987966")) + '("D7A3F7FC99CB46A9AC07A5FFAC8DBE4F3C8DFAEE" "CDDDB68DC28E1D1EE72AE3C3474E91381E45D7AB")) (defviewtest "Wrapping" "crt 10 ask turtles [ fd 6 ]" - '("72065F4E85CAE90DCFAE85AFC5A09295D46CD3D0" "CAABD296A8C72B18401F19C14C0DC83BB07718A9")) + '("51DACC1A8EE0758F94E8C3C1EC46467D46F796D0" "E08B45180949AB58E3F75A07DDC3CC07BC71DFDB")) (defviewtest "Die" "crt 10 ask turtles [ fd 1 ] ask turtles [ die ]" "62B8B468D5ED63CDFB567C984E0CAB53DBD03CEB") (defviewtest "rt" "crt 20 ask turtles [ fd 2 rt 100 fd 2 ]" - '("7E4DB3DBDE0F1C7D821629B89B8DC20ECFBF06AD" "9143414BB6DF425455C7ACBA6620FD51C9EC5E3A")) + '("1C325D14717E92D6368EF3D0276250A49AC94E3C" "6B8AE7C1F8AAB44934EFC17D3F8DC02EA93D42D0")) (defviewtest "lt" "crt 20 ask turtles [ fd 2 lt 100 fd 2 ]" - '("BF49775097BBFAE12E42D6F13FAFC93090B7ACAC" "ABAEAF8DDD68E7F0FED6CB243F27DB312588A1E8")) + '("5A9976BA3BFF49B9232CC8285E40709B43BB97C6" "24F764D346E607CD10C1CDA83CEF0091FDFBC280")) (defviewtest "pcolor green" "ask patches [ set pcolor green ]" "90F5F4870955B9FF02224F00E3C9814B8A6F766E") (defviewtest "size" "crt 10 ask turtles [ fd 2 set size 3 ] " - '("66E47E4579C2CA48CA672052B99F25DE94456D3A" "0A8EC908783A913CD15E9A0F19E6B8DBBA4EF5D9")) + '("E71BD61118B3B735DE4ADD2EF7897465084DD372" "6A4D9F29F10EAFCF5AB6156CCB35680EF4E41677")) -- 2.25.1 From 268b16dea9f447b3cf41090c44130d9b60807d7d Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Sun, 22 May 2016 14:37:07 -0500 Subject: [PATCH 11/16] Shapes - polygon, circle, rectangle --- resources/defaultshapes | 27 +++++ src/main/clnl.asd | 2 +- src/main/interface.lisp | 225 ++++++++++++++++++++++++++++++++++++---- src/main/nvm/nvm.lisp | 1 + 4 files changed, 233 insertions(+), 22 deletions(-) create mode 100644 resources/defaultshapes diff --git a/resources/defaultshapes b/resources/defaultshapes new file mode 100644 index 0000000..87b4db1 --- /dev/null +++ b/resources/defaultshapes @@ -0,0 +1,27 @@ +default +true +0 +Polygon -7500403 true true 150 5 40 250 150 205 260 250 + +sheep +false +15 +Circle -1 true true 203 65 88 +Circle -1 true true 70 65 162 +Circle -1 true true 150 105 120 +Polygon -7500403 true false 218 120 240 165 255 165 278 120 +Circle -7500403 true false 214 72 67 +Rectangle -1 true true 164 223 179 298 +Polygon -1 true true 45 285 30 285 30 240 15 195 45 210 +Circle -1 true true 3 83 150 +Rectangle -1 true true 65 221 80 296 +Polygon -1 true true 195 285 210 285 210 240 240 210 195 210 +Polygon -7500403 true false 276 85 285 105 302 99 294 83 +Polygon -7500403 true false 219 85 210 105 193 99 201 83 + +wolf +false +0 +Polygon -16777216 true false 253 133 245 131 245 133 +Polygon -7500403 true true 2 194 13 197 30 191 38 193 38 205 20 226 20 257 27 265 38 266 40 260 31 253 31 230 60 206 68 198 75 209 66 228 65 243 82 261 84 268 100 267 103 261 77 239 79 231 100 207 98 196 119 201 143 202 160 195 166 210 172 213 173 238 167 251 160 248 154 265 169 264 178 247 186 240 198 260 200 271 217 271 219 262 207 258 195 230 192 198 210 184 227 164 242 144 259 145 284 151 277 141 293 140 299 134 297 127 273 119 270 105 +Polygon -7500403 true true -1 195 14 180 36 166 40 153 53 140 82 131 134 133 159 126 188 115 227 108 236 102 238 98 268 86 269 92 281 87 269 103 269 113 diff --git a/src/main/clnl.asd b/src/main/clnl.asd index f66dbb6..17c3c3d 100644 --- a/src/main/clnl.asd +++ b/src/main/clnl.asd @@ -20,4 +20,4 @@ (:file "interface") (:file "cli") (:file "main")) - :depends-on #-travis(:cl-ppcre :mt19937 :cl-opengl :cl-glut :cl-charms :ieee-floats :strictmath) #+travis nil) + :depends-on #-travis(:cl-ppcre :mt19937 :cl-opengl :cl-glu :cl-glut :cl-charms :ieee-floats :strictmath) #+travis nil) diff --git a/src/main/interface.lisp b/src/main/interface.lisp index 95e2911..0f6fb59 100644 --- a/src/main/interface.lisp +++ b/src/main/interface.lisp @@ -1,12 +1,185 @@ (in-package #:clnl-interface) -(defvar *turtle-list* nil) +(defvar *turtle-lists* nil) (defvar *patch-list* nil) -; It may be useful to keep windows around (defvar *glut-window-opened* nil) (defvar *dimensions* nil) +; For now, shapes can live in here +; header is +; * name +; * rotatable (equal to "true" if yes) +; +; then after, the elements are like so: +; +; filled == filled in (always for now, ha) +; marked == use the turtle color instead of a color +; polygon -> Polygon +; circle -> Circle ; here, the left and top are NOT the center +; rectangle -> Rectangle +; +; then ends with an empty string + +(defun parse-circle (sections) + (list :circle + :color (parse-integer (car sections)) + :filled (string= (nth 1 sections) "true") + :marked (string= (nth 2 sections) "true") + :left (parse-integer (nth 3 sections)) + :top (parse-integer (nth 4 sections)) + :diameter (parse-integer (nth 5 sections)))) + +(defun parse-rectangle (sections) + (list + :rectangle + :color (parse-integer (car sections)) + :filled (string= (nth 1 sections) "true") + :marked (string= (nth 2 sections) "true") + :left (parse-integer (nth 3 sections)) + :top (parse-integer (nth 4 sections)) + :right (parse-integer (nth 5 sections)) + :bottom (parse-integer (nth 6 sections)))) + +(defun parse-polygon (sections) + (labels + ((parse-points (sections) + (when sections + (cons + (list (parse-integer (car sections)) (parse-integer (cadr sections))) + (parse-points (cddr sections)))))) + (list + :polygon + :color (parse-integer (car sections)) + :filled (string= (nth 1 sections) "true") + :marked (string= (nth 2 sections) "true") + :coords (parse-points (nthcdr 3 sections))))) + +(defun parse-shape (str) + (labels + ((parse-element (line) + (let + ((sections (cl-ppcre:split " " line))) + (cond + ((string= (car sections) "Circle") (parse-circle (cdr sections))) + ((string= (car sections) "Rectangle") (parse-rectangle (cdr sections))) + ((string= (car sections) "Polygon") (parse-polygon (cdr sections)))))) + (parse-elements () + (let + ((line (read-line str nil))) + (when (and line (string/= line "")) + (cons + (parse-element line) + (parse-elements)))))) + (let + ((next-line (read-line str nil))) + (when next-line + (list + :name next-line + :rotatable (string= "true" (read-line str)) + :rgb (read-line str) ; this is ignored for now, I think + :elements (parse-elements)))))) + +; Clipping ears algorithm. This can be slow due to the fact that it will only be run once. +(defun triangulate (points &optional (ccw :unknown)) + (labels + ((tri-is-ccw (x y z) + (< 0 (- (* (- (car y) (car x)) (- (cadr z) (cadr x))) (* (- (car z) (car x)) (- (cadr y) (cadr x)))))) + (tri-is-concave (x y z) (if (tri-is-ccw x y z) (not ccw) ccw)) + (poly-is-ccw (points &optional cur-tri) + (cond + ((not cur-tri) + (poly-is-ccw (append points (list (car points))) (list (car (last points)) (car points) (cadr points)))) + ((eql (length points) 2) + (apply #'tri-is-ccw cur-tri)) + ((or + (< (car (cadr points)) (car (cadr cur-tri))) + (and + (= (car (cadr points)) (car (cadr cur-tri))) + (< (cadr (cadr points)) (cadr (cadr cur-tri))))) + (poly-is-ccw (cdr points) (subseq points 0 3))) + (t (poly-is-ccw (cdr points) cur-tri)))) + (point-in-tri (x y z p) + ; Barycentric system test + (let* + ((denom (+ (* (- (cadr y) (cadr z)) (- (car x) (car z))) (* (- (car z) (car y)) (- (cadr x) (cadr z))))) + (a (/ (+ (* (- (cadr y) (cadr z)) (- (car p) (car z))) (* (- (car z) (car y)) (- (cadr p) (cadr z)))) denom)) + (b (/ (+ (* (- (cadr z) (cadr x)) (- (car p) (car z))) (* (- (car x) (car z)) (- (cadr p) (cadr z)))) denom)) + (c (- 1 a b))) + (and (<= 0 a 1) (<= 0 b 1) (<= 0 c 1)))) + (no-points-in-tri (tri points) + (every (lambda (point) (not (point-in-tri (car tri) (cadr tri) (caddr tri) point))) points)) + (tri-is-actually-line (x y z) + (zerop (+ (* (- (cadr y) (cadr z)) (- (car x) (car z))) (* (- (car z) (car y)) (- (cadr x) (cadr z))))))) + (cond + ((not (find :end points)) (triangulate (append points (list :end)) ccw)) + ((< (length points) 4) (error "Must have at least 3 points...")) + ((= (length points) 4) (list (remove :end points))) + ((eql ccw :unknown) (triangulate points (poly-is-ccw (remove :end points)))) + ((eql :end (car points)) (error "This polygon may not be triangulateable")) + (t + (let* + ((endless (remove :end points)) + (tri (subseq endless 0 3))) + (cond + ((apply #'tri-is-actually-line tri) + (triangulate (cons (car endless) (cddr endless)) ccw)) + ((apply #'tri-is-concave tri) + (triangulate (append (cdr points) (list (car points))) ccw)) + ((no-points-in-tri tri (nthcdr 3 endless)) + (cons tri (triangulate (cons (car endless) (cddr endless)) ccw))) + (t (triangulate (append (cdr points) (list (car points))) ccw)))))))) + +(defun element->gl-list (shape) + (case (car shape) + (:polygon + (progn + (gl:begin :triangles) + (mapcar + (lambda (point) (gl:vertex (car point) (cadr point) 0)) + (apply #'append (triangulate (getf (cdr shape) :coords)))) + (gl:end))) + (:rectangle + (progn + (gl:begin :triangles) + (mapcar + (lambda (point) (gl:vertex (car point) (cadr point) 0)) + (apply #'append + (triangulate + (list + (list (getf (cdr shape) :left) (getf (cdr shape) :top)) + (list (getf (cdr shape) :right) (getf (cdr shape) :top)) + (list (getf (cdr shape) :right) (getf (cdr shape) :bottom)) + (list (getf (cdr shape) :left) (getf (cdr shape) :bottom)))))) + (gl:end))) + (:circle + (progn + (gl:begin :triangles) + (mapcar + (lambda (point) (gl:vertex (car point) (cadr point) 0)) + (apply #'append + (triangulate + (loop + :repeat 360 + :with c := (strictmath:cos (strictmath:to-radians 1)) + :with s := (strictmath:sin (strictmath:to-radians 1)) + :with r := (/ (getf (cdr shape) :diameter) 2) + :with left := (getf (cdr shape) :left) + :with top := (getf (cdr shape) :top) + :for n := 0 :then x + :for x := r :then (- (* c x) (* s y)) + :for y := 0 :then (+ (* s n) (* c y)) + :collect (list (+ (+ x left) r) (+ (+ y top) r)))))) + (gl:end))))) + +(defun parse-shapes (str) + (let + ((shape (parse-shape str))) + (when shape (cons shape (parse-shapes str))))) + +(defun default-shapes () + (with-open-file (str "resources/defaultshapes") (parse-shapes str))) + (defvar *colors* '((140 140 140) ; gray (5) (215 48 39) ; red (15) @@ -66,10 +239,14 @@ (gl:with-pushed-matrix (gl:translate (* (getf turtle :xcor) (patch-size)) (* (getf turtle :ycor) (patch-size)) 0) (gl:translate x-modification y-modification 0) - (gl:rotate (getf turtle :heading) 0 0 -1) - (gl:scale (patch-size) (patch-size) 1) - (gl:scale (getf turtle :size) (getf turtle :size) 1) - (gl:call-list *turtle-list*))) + (let + ((turtle-list (find (getf turtle :shape) *turtle-lists* :test #'string= :key #'car))) + (when turtle-list + (when (second turtle-list) + (gl:rotate (getf turtle :heading) 0 0 -1)) + (gl:scale (patch-size) (patch-size) 1) + (gl:scale (getf turtle :size) (getf turtle :size) 1) + (gl:call-list (third turtle-list)))))) (list 0 (1- (world-width-in-pixels)) (- (1- (world-width-in-pixels))) 0 0) (list 0 0 0 (1- (world-height-in-pixels)) (- (1- (world-height-in-pixels)))))) turtles)) @@ -94,18 +271,24 @@ (cffi:defcallback close-func :void () (close-func)) (cffi:defcallback reshape :void ((width :int) (height :int)) (reshape width height)) -(defun set-turtle-list () - (setf *turtle-list* (gl:gen-lists 1)) - (gl:with-new-list (*turtle-list* :compile) - (gl:rotate 180 0 0 -1) - (gl:scale (/ 1 300d0) (/ 1d0 300d0) 1) - (gl:translate -150 -150 -0.0) - (gl:begin :polygon) - (gl:vertex 150 5 0) - (gl:vertex 40 250 0) - (gl:vertex 150 205 0) - (gl:vertex 260 250 0) - (gl:end))) +(defun set-turtle-lists () + (setf + *turtle-lists* + (mapcar + (lambda (shape) + (let + ((turtle-list + (list + (getf shape :name) + (getf shape :rotatable) + (gl:gen-lists 1)))) + (gl:with-new-list ((third turtle-list) :compile) + (gl:rotate 180d0 0d0 0d0 -1d0) + (gl:scale (/ 1d0 300d0) (/ 1d0 300d0) 1) + (gl:translate -150d0 -150d0 -0.0d0) + (mapcar #'element->gl-list (getf shape :elements))) + turtle-list)) + (default-shapes)))) (defun set-patch-list () (setf *patch-list* (gl:gen-lists 1)) @@ -157,7 +340,7 @@ DESCRIPTION: ; I do this because I don't know who or what in the many layers ; is causing the floating point errors, but I definitely don't ; want to investigate until simply ignoring them becomes a problem. - (sb-int:with-float-traps-masked (:invalid) + (sb-int:with-float-traps-masked (:invalid :inexact :divide-by-zero :overflow :underflow) (cl-glut:init) (cl-glut:init-window-size (world-width-in-pixels) @@ -170,7 +353,7 @@ DESCRIPTION: (glut:reshape-func (cffi:callback reshape)) (cl-glut:idle-func (cffi:get-callback 'idle)) (cl-glut:close-func (cffi:get-callback 'close-func)) - (set-turtle-list) + (set-turtle-lists) (set-patch-list) (cl-glut:main-loop))) @@ -205,7 +388,7 @@ DESCRIPTION: (cl-glut:init-window-size 1 1) (cl-glut:create-window "CLNL Test Window") (gl:clear-color 0 0 0 1) - (set-turtle-list) + (set-turtle-lists) (set-patch-list) (setf *glut-window-opened* t)) (let diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp index 5540cae..fa28fca 100644 --- a/src/main/nvm/nvm.lisp +++ b/src/main/nvm/nvm.lisp @@ -785,6 +785,7 @@ DESCRIPTION: :xcor (turtle-xcor turtle) :ycor (turtle-ycor turtle) :heading (turtle-heading turtle) + :shape (turtle-shape turtle) :size (turtle-size turtle))) *turtles*) (mapcar -- 2.25.1 From db4e12948a1751fbcd20cb76ce28973191b9eb5a Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Sat, 28 May 2016 14:24:49 -0500 Subject: [PATCH 12/16] Shapes - dynamic coloring for only parts of shapes --- src/main/interface.lisp | 42 +++++++++++++++++++++-------------------- src/test/viewtests.lisp | 6 ++++++ 2 files changed, 28 insertions(+), 20 deletions(-) diff --git a/src/main/interface.lisp b/src/main/interface.lisp index 0f6fb59..931cede 100644 --- a/src/main/interface.lisp +++ b/src/main/interface.lisp @@ -46,7 +46,7 @@ ((parse-points (sections) (when sections (cons - (list (parse-integer (car sections)) (parse-integer (cadr sections))) + (list (- 300 (parse-integer (car sections))) (parse-integer (cadr sections))) (parse-points (cddr sections)))))) (list :polygon @@ -131,30 +131,30 @@ (t (triangulate (append (cdr points) (list (car points))) ccw)))))))) (defun element->gl-list (shape) - (case (car shape) - (:polygon - (progn - (gl:begin :triangles) + (progn + (when (not (getf (cdr shape) :marked)) + (gl:push-attrib :all-attrib-bits) + (gl:color + (/ (ash (ldb (byte 24 0) (getf (cdr shape) :color)) -16) 255) + (/ (ash (ldb (byte 16 0) (getf (cdr shape) :color)) -8) 255) + (/ (ldb (byte 8 0) (getf (cdr shape) :color)) 255))) + (gl:begin :triangles) + (case (car shape) + (:polygon (mapcar (lambda (point) (gl:vertex (car point) (cadr point) 0)) - (apply #'append (triangulate (getf (cdr shape) :coords)))) - (gl:end))) - (:rectangle - (progn - (gl:begin :triangles) + (apply #'append (triangulate (getf (cdr shape) :coords))))) + (:rectangle (mapcar (lambda (point) (gl:vertex (car point) (cadr point) 0)) (apply #'append (triangulate (list - (list (getf (cdr shape) :left) (getf (cdr shape) :top)) - (list (getf (cdr shape) :right) (getf (cdr shape) :top)) - (list (getf (cdr shape) :right) (getf (cdr shape) :bottom)) - (list (getf (cdr shape) :left) (getf (cdr shape) :bottom)))))) - (gl:end))) - (:circle - (progn - (gl:begin :triangles) + (list (- 300 (getf (cdr shape) :left)) (getf (cdr shape) :top)) + (list (- 300 (getf (cdr shape) :right)) (getf (cdr shape) :top)) + (list (- 300 (getf (cdr shape) :right)) (getf (cdr shape) :bottom)) + (list (- 300 (getf (cdr shape) :left)) (getf (cdr shape) :bottom))))))) + (:circle (mapcar (lambda (point) (gl:vertex (car point) (cadr point) 0)) (apply #'append @@ -169,8 +169,10 @@ :for n := 0 :then x :for x := r :then (- (* c x) (* s y)) :for y := 0 :then (+ (* s n) (* c y)) - :collect (list (+ (+ x left) r) (+ (+ y top) r)))))) - (gl:end))))) + :collect (list (- 300 (+ (+ x left) r)) (+ (+ y top) r)))))))) + (gl:end) + (when (not (getf (cdr shape) :marked)) + (gl:pop-attrib)))) (defun parse-shapes (str) (let diff --git a/src/test/viewtests.lisp b/src/test/viewtests.lisp index 3455b28..2f5eabb 100644 --- a/src/test/viewtests.lisp +++ b/src/test/viewtests.lisp @@ -26,3 +26,9 @@ (defviewtest "size" "crt 10 ask turtles [ fd 2 set size 3 ] " '("E71BD61118B3B735DE4ADD2EF7897465084DD372" "6A4D9F29F10EAFCF5AB6156CCB35680EF4E41677")) + +(defviewtest "sheep" "set-default-shape turtles \"sheep\" crt 10 ask turtles [ fd 2 set size 3 ] " + '("6D86C178B84836F064C0084E9A0BDE3BACCA28A2" "33DD3FA4103731FA6A2EA675104CEEFCE16ADF54")) + +(defviewtest "wolves" "set-default-shape turtles \"wolf\" crt 10 ask turtles [ fd 2 set size 3 ] " + '("D455A70DBAD3195F23328B58B4D123934FEA0DC0" "4C108D1B2ED37A9C2152BE816E2B8947861333DE")) -- 2.25.1 From 885270b122c568ecdba52a465dae0125adae8c18 Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Sun, 29 May 2016 09:32:08 -0500 Subject: [PATCH 13/16] Code reformat - Break up nvm files, package declaration based on dictionary grouping --- src/main/clnl.asd | 7 + src/main/code-parse.lisp | 1 - src/main/nvm/agentset.lisp | 147 +++++++ src/main/nvm/controlflow.lisp | 52 +++ src/main/nvm/inout.lisp | 96 +++++ src/main/nvm/math.lisp | 47 +++ src/main/nvm/nvm.lisp | 740 ++-------------------------------- src/main/nvm/package.lisp | 34 ++ src/main/nvm/turtles.lisp | 250 ++++++++++++ src/main/nvm/world.lisp | 100 +++++ src/main/package.lisp | 38 -- 11 files changed, 759 insertions(+), 753 deletions(-) create mode 100644 src/main/nvm/agentset.lisp create mode 100644 src/main/nvm/controlflow.lisp create mode 100644 src/main/nvm/inout.lisp create mode 100644 src/main/nvm/math.lisp create mode 100644 src/main/nvm/package.lisp create mode 100644 src/main/nvm/turtles.lisp create mode 100644 src/main/nvm/world.lisp diff --git a/src/main/clnl.asd b/src/main/clnl.asd index 17c3c3d..58bd44b 100644 --- a/src/main/clnl.asd +++ b/src/main/clnl.asd @@ -4,6 +4,7 @@ :maintainer "Frank Duncan (frank@kank.com)" :author "Frank Duncan (frank@kank.com)" :components ((:file "package") + (:file "nvm/package") (:file "base") (:file "extensions") (:file "model") @@ -14,6 +15,12 @@ (:file "nvm/utils") (:file "nvm/agent") (:file "nvm/nvm") + (:file "nvm/agentset") + (:file "nvm/controlflow") + (:file "nvm/inout") + (:file "nvm/math") + (:file "nvm/turtles") + (:file "nvm/world") (:file "nvm/topology") (:file "transpile") (:file "random") diff --git a/src/main/code-parse.lisp b/src/main/code-parse.lisp index 4e75407..e159f39 100644 --- a/src/main/code-parse.lisp +++ b/src/main/code-parse.lisp @@ -21,7 +21,6 @@ (defun breed->prims (breed-list) (let* ((plural (car breed-list)) - (singular (cadr breed-list)) (plural-name (symbol-name plural))) (list (list :name plural :type :reporter :precedence 10 :macro `(lambda () ,plural)) diff --git a/src/main/nvm/agentset.lisp b/src/main/nvm/agentset.lisp new file mode 100644 index 0000000..b419f97 --- /dev/null +++ b/src/main/nvm/agentset.lisp @@ -0,0 +1,147 @@ +(in-package #:clnl-nvm) + +(defun count (agentset) + "COUNT AGENTSET => N + +ARGUMENTS AND VALUES: + + AGENTSET: a NetLogo agentset + N: a number + +DESCRIPTION: + + COUNT is equivalent to count in NetLogo. Returns N, the number of + agents in AGENTSET. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#count" + (coerce (length (agentset-list agentset)) 'double-float)) + +(defun of (fn agent-or-agentset) + "OF FN AGENT-OR-AGENTSET => RESULT + + AGENT-OR-AGENTSET: AGENT | AGENTSET + RESULT: RESULT-LIST | RESULT-VALUE + +ARGUMENTS AND VALUES: + + FN: a function, run on each agent + AGENT: a NetLogo agent + AGENTSET: a NetLogo agentset + RESULT-LIST: a list + RESULT-VALUE: a single value + +DESCRIPTION: + + OF is equivalent to of in NetLogo. + + The specified AGENTSET or AGENT runs the given FN. In the case of an + AGENTSET, the order in which the agents are run is random each time, + and only agents that are in the set at the beginning of the call. + + RESULT-LIST is returned when the input is an AGENTSET, but RESULT-VALUE + is returned when only passed an AGENT. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#of" + (cond + ((agentset-p agent-or-agentset) + (let + ((iter (shufflerator (agentset-list agent-or-agentset)))) + (loop + :for agent := (funcall iter) + :while agent + :collect (let ((*myself* *self*) (*self* agent)) (funcall fn))))) + ((agent-p agent-or-agentset) + (let ((*myself* *self*) (*self* agent-or-agentset)) (funcall fn))) + (t + (error "Of requires an agentset or agent but got: ~A" agent-or-agentset)))) + +(defun one-of (list-or-agentset) + "ONE-OF LIST-OR-AGENTSET => RESULT + + LIST-OR-AGENTSET: LIST | AGENTSET + RESULT: RANDOM-VALUE | RANDOM-AGENT | :nobody + +ARGUMENTS AND VALUES: + + LIST: A list + AGENTSET: An agent set + RANDOM-VALUE: a value in LIST + RANDOM-AGENT: an agent if AGENTSET is non empty + +DESCRIPTION: + + From an AGENTSET, returns a RANDOM-AGENT. If the agentset is empty, returns :nobody. + From a list, returns a RANDOM-VALUE. If the list is empty, an error occurs. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#one-of" + (cond + ((agentset-p list-or-agentset) + (let* + ((agentset-list (agentset-list list-or-agentset)) + (length (length agentset-list))) + (if (zerop length) :nobody (nth (clnl-random:next-int length) agentset-list)))) + ((listp list-or-agentset) + (let* + ((length (length list-or-agentset))) + (if (zerop length) + (error "one-of requires a nonempty list") + (nth (clnl-random:next-int length) list-or-agentset)))) + (t (error "one-of requires a list or agentset")))) + +(defun patches () + "PATCHES => ALL-PATCHES + +ARGUMENTS AND VALUES: + + ALL-PATCHES: a NetLogo agentset, all patches + +DESCRIPTION: + + Reports the agentset consisting of all the patches. + + This agentset is special in that it represents the living patches + each time it's used, so changes depending on the state of the engine. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#patches" + :patches) + +(defun turtles () + "TURTLES => ALL-TURTLES + +ARGUMENTS AND VALUES: + + ALL-TURTLES: a NetLogo agentset, all turtles + +DESCRIPTION: + + Reports the agentset consisting of all the turtles. + + This agentset is special in that it represents the living turtles + each time it's used, so changes depending on the state of the engine. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles" + :turtles) + +(defun with (agentset fn) + "WITH AGENTSET FN => RESULT-AGENTSET + +ARGUMENTS AND VALUES: + + AGENTSET: a NetLogo agentset + FN: a boolean function, run on each agent to determine if included + RESULT-AGENTSET: an agentset of valid agents + +DESCRIPTION: + + WITH is equivalent to with in NetLogo. + + Returns a new agentset containing only those agents that reported true + when FN is called. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#with" + (list->agentset + (remove-if-not + (lambda (agent) + (let ((*myself* *self*) (*self* agent)) (funcall fn))) + (agentset-list agentset)) + (agentset-breed agentset))) diff --git a/src/main/nvm/controlflow.lisp b/src/main/nvm/controlflow.lisp new file mode 100644 index 0000000..a1df63b --- /dev/null +++ b/src/main/nvm/controlflow.lisp @@ -0,0 +1,52 @@ +(in-package #:clnl-nvm) + +(defun ask (agent-or-agentset fn) + "ASK AGENT-OR-AGENTSET FN => RESULT + + AGENT-OR-AGENTSET: AGENT | AGENTSET + +ARGUMENTS AND VALUES: + + FN: a function, run on each agent + RESULT: undefined, commands don't return + AGENT: a NetLogo agent + AGENTSET: a NetLogo agentset + +DESCRIPTION: + + ASK is equivalent to ask in NetLogo. + + The specified AGENTSET or AGENT runs the given FN. In the case of an + AGENTSET, the order in which the agents are run is random each time, + and only agents that are in the set at the beginning of the call. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ask" + (cond + ((agentset-p agent-or-agentset) + (let + ((iter (shufflerator (agentset-list agent-or-agentset)))) + (loop + :for agent := (funcall iter) + :while agent + :do (when (not (and (turtle-p agent) (= -1 (turtle-who agent)))) + (let ((*myself* *self*) (*self* agent)) (with-stop-and-death-handler (funcall fn))))))) + ((agent-p agent-or-agentset) + (let ((*myself* *self*) (*self* agent-or-agentset)) (with-stop-and-death-handler (funcall fn)))) + (t + (error "Ask requires an agentset or agent but got: ~A" agent-or-agentset)))) + +(defun stop () + "STOP => RESULT + +ARGUMENTS AND VALUES: + + RESULT: undefined + +DESCRIPTION: + + Returns from the current stop block, which will halt the currently running + thing, be that the program, current ask block, or procedure. Stop has odd + semantics that are best gleaned from the actual NetLogo manual. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#stop" + (error (make-condition 'stop))) diff --git a/src/main/nvm/inout.lisp b/src/main/nvm/inout.lisp new file mode 100644 index 0000000..7a78cf2 --- /dev/null +++ b/src/main/nvm/inout.lisp @@ -0,0 +1,96 @@ +(in-package #:clnl-nvm) + +(defun export-turtles () + (append + (list + "\"TURTLES\"" + (format nil "~A~A~{,\"~A\"~}" + "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\"," + "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\"" + (mapcar #'string-downcase *turtles-own-vars*))) + (mapcar + (lambda (turtle) + (format nil + "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"false\",\"~A\",~A~{,\"~A\"~}" + (dump-object (turtle-who turtle)) + (dump-object (turtle-color turtle)) + (dump-object (turtle-heading turtle)) + (dump-object (turtle-xcor turtle)) + (dump-object (turtle-ycor turtle)) + (dump-object (turtle-shape turtle)) + (dump-object (turtle-label turtle)) + (dump-object (turtle-label-color turtle)) + (dump-object (turtle-breed turtle)) + (dump-object (turtle-size turtle)) + "\"1\",\"\"\"up\"\"\"" + (mapcar #'dump-object (mapcar (lambda (var) (agent-value-inner turtle var)) *turtles-own-vars*)))) + *turtles*))) + +(defun export-patches () + (append + (list + "\"PATCHES\"" + (format nil "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"~{,\"~A\"~}" + (mapcar #'string-downcase *patches-own-vars*))) + (mapcar + (lambda (patch) + (format nil + "\"~A\",\"~A\",\"~A\",\"\"\"\"\"\",\"9.9\"~{,\"~A\"~}" + (dump-object (patch-xcor patch)) + (dump-object (patch-ycor patch)) + (dump-object (patch-color patch)) + (mapcar #'dump-object (mapcar (lambda (var) (agent-value-inner patch var)) *patches-own-vars*)))) + *patches*))) + +(defun export-world () + "EXPORT-WORLD => WORLD-CSV + +ARGUMENTS AND VALUES: + + WORLD-CSV: A string, the csv of the world + +DESCRIPTION: + + Dumps out a csv matching NetLogo's export world. + + This is useful for serializing the current state of the engine in order + to compare against NetLogo or to reimport later. Contains everything needed + to boot up a NetLogo instance in the exact same state." + (let + ((ordered-globals (sort (copy-list *globals*) #'string< :key (lambda (global) (symbol-name (car global)))))) + (format nil "~{~A~%~}" + (list + (format nil "~S" "RANDOM STATE") + (format nil "~S" (clnl-random:export)) + "" + (format nil "~S" "GLOBALS") + (format nil "~A~A~{\"~A\"~^,~}" + "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\"," + "\"nextIndex\",\"directed-links\",\"ticks\"," + (mapcar #'string-downcase (mapcar #'car ordered-globals))) + (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"~A\"~{,\"~A\"~}" + (min-pxcor) (max-pxcor) (min-pycor) (max-pycor) *current-id* (dump-object (or *ticks* -1d0)) + (mapcar #'dump-object (mapcar #'funcall (mapcar #'cadr ordered-globals)))) + "" + (format nil "~{~A~^~%~}" (export-turtles)) + "" + (format nil "~{~A~^~%~}" (export-patches)) + "" + (format nil "~S" "LINKS") + "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\"" + "")))) + +(defun show (value) + "SHOW VALUE => RESULT + +ARGUMENTS AND VALUES: + + VALUE: a NetLogo value + RESULT: undefined + +DESCRIPTION: + + A command that prints the given NetLogo value to the command center. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#show" + (format t "Showing: ~A~%" (dump-object value))) diff --git a/src/main/nvm/math.lisp b/src/main/nvm/math.lisp new file mode 100644 index 0000000..d7b9422 --- /dev/null +++ b/src/main/nvm/math.lisp @@ -0,0 +1,47 @@ +(in-package #:clnl-nvm) + +(defun random-float (n) + "RANDOM-FLOAT N => RANDOM-NUMBER + +ARGUMENTS AND VALUES: + + N: a double, the upper bound of the random float + RANDOM-NUMBER: a double, the random result + +DESCRIPTION: + + Returns a random number strictly closer to zero than N. + + If number is positive, returns a random floating point number greater than + or equal to 0 but strictly less than number. + + If number is negative, returns a random floating point number less than or equal + to 0, but strictly greater than number. + + If number is zero, the result is always 0. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-float" + (clnl-random:next-double n)) + +(defun random (n) + "RANDOM N => RANDOM-NUMBER + +ARGUMENTS AND VALUES: + + N: an integer, the upper bound of the random + RANDOM-NUMBER: an integer, the random result + +DESCRIPTION: + + Returns a random number strictly closer to zero than N. + + If number is positive, returns a random integer greater than or equal to 0, + but strictly less than number. + + If number is negative, returns a random integer less than or equal to 0, + but strictly greater than number. + + If number is zero, the result is always 0. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random" + (coerce (clnl-random:next-long (truncate n)) 'double-float)) diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp index fa28fca..7927909 100644 --- a/src/main/nvm/nvm.lisp +++ b/src/main/nvm/nvm.lisp @@ -1,22 +1,5 @@ (in-package #:clnl-nvm) -; Implementations of all the things the nvm can do. - -(defun show (value) - "SHOW VALUE => RESULT - -ARGUMENTS AND VALUES: - - VALUE: a NetLogo value - RESULT: undefined - -DESCRIPTION: - - A command that prints the given NetLogo value to the command center. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#show" - (format t "Showing: ~A~%" (dump-object value))) - (defun lookup-color (color) "LOOKUP-COLOR COLOR => COLOR-NUMBER @@ -73,248 +56,6 @@ DESCRIPTION: (incf *current-id*) new-turtle)) -(defun die () - "DIE => RESULT - -ARGUMENTS AND VALUES: - - RESULT: undefined, commands don't return - -DESCRIPTION: - - The turtle or link dies - - A dead agent ceases to exist. The effects of this include: - - The agent will not execute any further code. - - The agent will disappear from any agentsets it was in, reducing the size of those agentsets by one. - - Any variable that was storing the agent will now instead have nobody in it. - - If the dead agent was a turtle, every link connected to it also dies. - - If the observer was watching or following the agent, the observer's perspective resets. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#die" - (when (not (turtle-p *self*)) (error "Gotta call die in turtle scope, dude (~A)" *self*)) - (setf (turtle-who *self*) -1) - (setf *turtles* (remove *self* *turtles*)) - (let - ((patch (patch-at (turtle-xcor *self*) (turtle-ycor *self*)))) - (setf (patch-turtles patch) (remove *self* (patch-turtles patch)))) - (error (make-condition 'death))) - -(defun patches () - "PATCHES => ALL-PATCHES - -ARGUMENTS AND VALUES: - - ALL-PATCHES: a NetLogo agentset, all patches - -DESCRIPTION: - - Reports the agentset consisting of all the patches. - - This agentset is special in that it represents the living patches - each time it's used, so changes depending on the state of the engine. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#patches" - :patches) - -(defun turtles () - "TURTLES => ALL-TURTLES - -ARGUMENTS AND VALUES: - - ALL-TURTLES: a NetLogo agentset, all turtles - -DESCRIPTION: - - Reports the agentset consisting of all the turtles. - - This agentset is special in that it represents the living turtles - each time it's used, so changes depending on the state of the engine. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles" - :turtles) - -(defun turtles-here (&optional breed) - "TURTLES-HERE => TURTLES - -ARGUMENTS AND VALUES: - - TURTLES: an agentset - -DESCRIPTION: - - Returns the agentset consisting of all the turtles sharing the patch - with the agent in by *self* - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles-here" - (when (not (turtle-p *self*)) (error "Gotta call turtles-here with a turtle")) - (let - ((patch-turtles (patch-turtles (patch-at (turtle-xcor *self*) (turtle-ycor *self*))))) - (list->agentset - (if breed (remove breed patch-turtles :key #'turtle-breed :test-not #'eql) patch-turtles) - (or breed :turtles)))) - -(defun ask (agent-or-agentset fn) - "ASK AGENT-OR-AGENTSET FN => RESULT - - AGENT-OR-AGENTSET: AGENT | AGENTSET - -ARGUMENTS AND VALUES: - - FN: a function, run on each agent - RESULT: undefined, commands don't return - AGENT: a NetLogo agent - AGENTSET: a NetLogo agentset - -DESCRIPTION: - - ASK is equivalent to ask in NetLogo. - - The specified AGENTSET or AGENT runs the given FN. In the case of an - AGENTSET, the order in which the agents are run is random each time, - and only agents that are in the set at the beginning of the call. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ask" - (cond - ((agentset-p agent-or-agentset) - (let - ((iter (shufflerator (agentset-list agent-or-agentset)))) - (loop - :for agent := (funcall iter) - :while agent - :do (when (not (and (turtle-p agent) (= -1 (turtle-who agent)))) - (let ((*myself* *self*) (*self* agent)) (with-stop-and-death-handler (funcall fn))))))) - ((agent-p agent-or-agentset) - (let ((*myself* *self*) (*self* agent-or-agentset)) (with-stop-and-death-handler (funcall fn)))) - (t - (error "Ask requires an agentset or agent but got: ~A" agent-or-agentset)))) - -(defun count (agentset) - "COUNT AGENTSET => N - -ARGUMENTS AND VALUES: - - AGENTSET: a NetLogo agentset - N: a number - -DESCRIPTION: - - COUNT is equivalent to count in NetLogo. Returns N, the number of - agents in AGENTSET. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#count" - (coerce (length (agentset-list agentset)) 'double-float)) - -(defun clear-all () - "CLEAR-ALL => RESULT - -ARGUMENTS AND VALUES: - - RESULT: undefined - -DESCRIPTION: - - Clears ticks, turtles, patches, globals (unimplemented). - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#clear-all" - (clear-turtles) - (clear-patches) - (clear-ticks)) - -(defun display () - "DISPLAY => RESULT - -ARGUMENTS AND VALUES: - - RESULT: undefined - -DESCRIPTION: - - As of yet, this does nothing. A placeholder method for forced dipslay - updates from the engine. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#display" - nil) - -(defun stop () - "STOP => RESULT - -ARGUMENTS AND VALUES: - - RESULT: undefined - -DESCRIPTION: - - Returns from the current stop block, which will halt the currently running - thing, be that the program, current ask block, or procedure. Stop has odd - semantics that are best gleaned from the actual NetLogo manual. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#stop" - (error (make-condition 'stop))) - -(defun of (fn agent-or-agentset) - "OF FN AGENT-OR-AGENTSET => RESULT - - AGENT-OR-AGENTSET: AGENT | AGENTSET - RESULT: RESULT-LIST | RESULT-VALUE - -ARGUMENTS AND VALUES: - - FN: a function, run on each agent - AGENT: a NetLogo agent - AGENTSET: a NetLogo agentset - RESULT-LIST: a list - RESULT-VALUE: a single value - -DESCRIPTION: - - OF is equivalent to of in NetLogo. - - The specified AGENTSET or AGENT runs the given FN. In the case of an - AGENTSET, the order in which the agents are run is random each time, - and only agents that are in the set at the beginning of the call. - - RESULT-LIST is returned when the input is an AGENTSET, but RESULT-VALUE - is returned when only passed an AGENT. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#of" - (cond - ((agentset-p agent-or-agentset) - (let - ((iter (shufflerator (agentset-list agent-or-agentset)))) - (loop - :for agent := (funcall iter) - :while agent - :collect (let ((*myself* *self*) (*self* agent)) (funcall fn))))) - ((agent-p agent-or-agentset) - (let ((*myself* *self*) (*self* agent-or-agentset)) (funcall fn))) - (t - (error "Of requires an agentset or agent but got: ~A" agent-or-agentset)))) - -(defun with (agentset fn) - "WITH AGENTSET FN => RESULT-AGENTSET - -ARGUMENTS AND VALUES: - - AGENTSET: a NetLogo agentset - FN: a boolean function, run on each agent to determine if included - RESULT-AGENTSET: an agentset of valid agents - -DESCRIPTION: - - WITH is equivalent to with in NetLogo. - - Returns a new agentset containing only those agents that reported true - when FN is called. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#with" - (list->agentset - (remove-if-not - (lambda (agent) - (let ((*myself* *self*) (*self* agent)) (funcall fn))) - (agentset-list agentset)) - (agentset-breed agentset))) - (defun shufflerator (agentset-list) (let ((copy (copy-list agentset-list)) @@ -335,355 +76,6 @@ DESCRIPTION: ((= i (length copy)) (incf i) (car (last copy))) (t (let ((result agent)) (fetch) result))))))) -(defun random-float (n) - "RANDOM-FLOAT N => RANDOM-NUMBER - -ARGUMENTS AND VALUES: - - N: a double, the upper bound of the random float - RANDOM-NUMBER: a double, the random result - -DESCRIPTION: - - Returns a random number strictly closer to zero than N. - - If number is positive, returns a random floating point number greater than - or equal to 0 but strictly less than number. - - If number is negative, returns a random floating point number less than or equal - to 0, but strictly greater than number. - - If number is zero, the result is always 0. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-float" - (clnl-random:next-double n)) - -(defun random (n) - "RANDOM N => RANDOM-NUMBER - -ARGUMENTS AND VALUES: - - N: an integer, the upper bound of the random - RANDOM-NUMBER: an integer, the random result - -DESCRIPTION: - - Returns a random number strictly closer to zero than N. - - If number is positive, returns a random integer greater than or equal to 0, - but strictly less than number. - - If number is negative, returns a random integer less than or equal to 0, - but strictly greater than number. - - If number is zero, the result is always 0. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random" - (coerce (clnl-random:next-long (truncate n)) 'double-float)) - -(defun random-xcor () - "RANDOM-XCOR => RANDOM-NUMBER - -ARGUMENTS AND VALUES: - - RANDOM-NUMBER: a float, the random result - -DESCRIPTION: - - Returns a random floating point number in the allowable range of turtle - coordinates along the x axis. - - These range from min-pxcor - 0.5 (inclusive) to max-pxcor + 0.5 (exclusive) - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-cor" - (let - ((min (- (min-pxcor) 0.5d0)) - (max (+ (max-pxcor) 0.5d0))) - (+ min (clnl-random:next-double (- max min))))) - -(defun random-ycor () - "RANDOM-YCOR => RANDOM-NUMBER - -ARGUMENTS AND VALUES: - - RANDOM-NUMBER: a float, the random result - -DESCRIPTION: - - Returns a random floating point number in the allowable range of turtle - coordinates along the y axis. - - These range from min-pycor - 0.5 (inclusive) to max-pycor + 0.5 (exclusive) - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-cor" - (let - ((min (- (min-pycor) 0.5d0)) - (max (+ (max-pycor) 0.5d0))) - (+ min (clnl-random:next-double (- max min))))) - -(defun one-of (list-or-agentset) - "ONE-OF LIST-OR-AGENTSET => RESULT - - LIST-OR-AGENTSET: LIST | AGENTSET - RESULT: RANDOM-VALUE | RANDOM-AGENT | :nobody - -ARGUMENTS AND VALUES: - - LIST: A list - AGENTSET: An agent set - RANDOM-VALUE: a value in LIST - RANDOM-AGENT: an agent if AGENTSET is non empty - -DESCRIPTION: - - From an AGENTSET, returns a RANDOM-AGENT. If the agentset is empty, returns :nobody. - From a list, returns a RANDOM-VALUE. If the list is empty, an error occurs. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#one-of" - (cond - ((agentset-p list-or-agentset) - (let* - ((agentset-list (agentset-list list-or-agentset)) - (length (length agentset-list))) - (if (zerop length) :nobody (nth (clnl-random:next-int length) agentset-list)))) - ((listp list-or-agentset) - (let* - ((length (length list-or-agentset))) - (if (zerop length) - (error "one-of requires a nonempty list") - (nth (clnl-random:next-int length) list-or-agentset)))) - (t (error "one-of requires a list or agentset")))) - -(defun jump (n) - (when (not (turtle-p *self*)) (error "Gotta call jump in turtle scope, dude (~A)" *self*)) - (with-patch-update *self* - (setf - (turtle-xcor *self*) - (wrap-x *topology* - (+ (turtle-xcor *self*) (* n (using-cached-sin (turtle-heading *self*)))))) - (setf - (turtle-ycor *self*) - (wrap-y *topology* - (+ (turtle-ycor *self*) (* n (using-cached-cos (turtle-heading *self*)))))))) - -(defun setxy (x y) - "SETXY X Y => RESULT - -ARGUMENTS AND VALUES: - - X: a double - Y: a double - RESULT: undefined - -DESCRIPTION: - - Sets the x-coordinate and y-coordinate for the turle. Equivalent to - set xcor x set ycor y, except it happens in one step inside of two. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#setxy" - (when (not (turtle-p *self*)) (error "Gotta call setxy in turtle scope, dude (~A)" *self*)) - (setf (turtle-xcor *self*) (wrap-x *topology* x)) - (setf (turtle-ycor *self*) (wrap-y *topology* y))) - -(defun set-default-shape (breed shape) - "SET-DEFAULT-SHAPE BREED SHAPE => RESULT - -ARGUMENTS AND VALUES: - - BREED: a valid breed - SHAPE: a string - RESULT: undefined - -DESCRIPTION: - - Specifies a default initial shape for a BREED. When a turtle, or it changes breeds, - its shape is set to the given shape. - - SET-DEFAULT-SHAPE doesn't affect existing agents, only agents you create afterwards. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#set-default-shape" - (when (not (breed-p breed)) (error "Need a valid breed")) - (setf (breed-default-shape breed) shape)) - -(defun forward (n) - "FORWARD N => RESULT - -ARGUMENTS AND VALUES: - - N: a double, the amount the turtle moves forward - RESULT: undefined - -DESCRIPTION: - - Moves the current turtle forward N steps, one step at a time. - - This moves forward one at a time in order to make the view updates look - good in the case of a purposefully slow running instance. If the number - is negative, the turtle moves backward. - - If the current agent is not a turtle, it raises an error. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#forward" - (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*)) - (labels - ((internal (i) - (cond - ((< (abs i) 3.2e-15) nil) - ((< (abs i) 1d0) (jump i)) - (t (jump (if (> i 0d0) 1d0 -1d0)) (internal (- i (if (> i 0d0) 1d0 -1d0))))))) - (internal n))) - -(defun turn-right (n) - "TURN-RIGHT N => RESULT - -ARGUMENTS AND VALUES: - - N: a double, the amount the turtle turns - RESULT: undefined - -DESCRIPTION: - - The turtle turns right by number degrees. (If number is negative, it turns left.) - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right" - (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*)) - (let - ((new-heading (+ (turtle-heading *self*) n))) - (setf (turtle-heading *self*) - (cond - ((< new-heading 0) (+ (mod new-heading -360) 360)) - ((>= new-heading 360) (mod new-heading 360)) - (t new-heading))))) - -(defun turn-left (n) - "TURN-LEFT N => RESULT - -ARGUMENTS AND VALUES: - - N: a double, the amount the turtle turns - RESULT: undefined - -DESCRIPTION: - - The turtle turns left by number degrees. (If number is negative, it turns right.) - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right" - (turn-right (- n))) - -(defun create-turtles (n &optional breed fn) - "CREATE-TURTLES N &optional BREED FN => RESULT - -ARGUMENTS AND VALUES: - - N: an integer, the numbers of turtles to create - BREED: a breed - FN: A function, applied to each turtle after creation - RESULT: undefined - -DESCRIPTION: - - Creates N new turtles at the origin. - - New turtles have random integer headings and the color is randomly selected - from the 14 primary colors. If FN is supplied, the new turtles immediately - run it. If a BREED is supplied, that is the breed the new turtles are set - to. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles" - (let - ((new-turtles (loop :repeat n :collect (create-turtle breed)))) - (when fn (ask (list->agentset new-turtles :turtles) fn)))) - -(defun hatch (n &optional fn) - "HATCH N &optional FN => RESULT - -ARGUMENTS AND VALUES: - - N: an integer, the numbers of turtles to hatch - FN: A function, applied to each turtle after creation - RESULT: undefined - -DESCRIPTION: - - The turtle in *self* creates N new turtles. Each new turtle inherits of all its - variables, including its location, from self. - - If FN is supplied, the new turtles immediately run it. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#hatch" - (when (not (turtle-p *self*)) (error "Can only hatch from turtle scope")) - (let - ((new-turtles (loop :repeat n :collect (create-turtle nil *self*)))) - (when fn (ask (list->agentset new-turtles :turtles) fn)))) - -(defun reset-ticks () - "RESET-TICKS => RESULT - -ARGUMENTS AND VALUES: - - RESULT: undefined - -DESCRIPTION: - - Resets the tick counter to zero, sets up all plots, then updates all plots. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#reset-ticks" - (setf *ticks* 0d0)) - -(defun tick () - "RESET-TICKS => RESULT - -ARGUMENTS AND VALUES: - - RESULT: undefined - -DESCRIPTION: - - Advances the tick counter by one and updates all plots. - - If the tick counter has not been started yet with reset-ticks, an error results. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#tick" - - (when (not *ticks*) (error "reset-ticks must be called")) - (incf *ticks*)) - -(defun ticks () - "TICKS => CURRENT-TICKS - -ARGUMENTS AND VALUES: - - CURRENT-TICKS: A positiv double, representing the current number of ticks - -DESCRIPTION: - - Reports the current value of the tick counter. The result is always a number and never negative. - - If the tick counter has not been started yet with reset-ticks, an error results. - - See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ticks" - (when (not *ticks*) (error "reset-ticks must be called")) - *ticks*) - -(defun clear-patches () - (setf - *patches* - (loop - :for y :from (max-pycor) :downto (min-pycor) - :append (loop - :for x :from (min-pxcor) :to (max-pxcor) - :collect (make-patch - :xcor (coerce x 'double-float) - :ycor (coerce y 'double-float) - :color 0d0))))) - -(defun clear-turtles () - (setf *turtles* nil) - (setf *current-id* 0)) - -(defun clear-ticks () - (setf *ticks* nil)) - (defun create-world (&key dims globals turtles-own-vars patches-own-vars breeds) "CREATE-WORLD &key DIMS GLOBALS TURTLES-OWN-VARS PATCHES-OWN-VARS BREEDS => RESULT @@ -725,39 +117,6 @@ DESCRIPTION: (clear-patches) (clear-turtles)) -; These match netlogo's dump -(defgeneric dump-object (o)) - -(defmethod dump-object ((n double-float)) - (multiple-value-bind (int rem) (floor n) - (if (eql 0d0 rem) - (format nil "~A" int) - (let - ((output (format nil "~D" n))) - ; Someday we'll have d, but this is not that day! - (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-"))))) - -(defmethod dump-object ((o string)) (format nil "~A" (cl-ppcre:regex-replace-all "\"" (format nil "~S" o) "\"\""))) - -(defmethod dump-object ((o (eql t))) "true") -(defmethod dump-object ((o (eql nil))) "false") - -(defmethod dump-object ((o list)) - (cond - ((agentset-p o) (format nil "(agentset, ~A ~A)" (dump-object (count o)) (string-downcase (agentset-breed o)))) - (t (format nil "[~{~A~^ ~}]" (mapcar #'dump-object o))))) - -(defmethod dump-object ((o patch)) - (format nil "(patch ~A ~A)" (dump-object (patch-xcor o)) (dump-object (patch-ycor o)))) - -(defmethod dump-object ((o turtle)) (format nil "(turtle ~A)" (dump-object (turtle-who o)))) -(defmethod dump-object ((o (eql :nobody))) (format nil "nobody")) -(defmethod dump-object ((o (eql :turtles))) (format nil "{all-turtles}")) -(defmethod dump-object ((o symbol)) - (cond - ((find o *breeds* :key #'car) (format nil "{breed ~(~A~)}" o)) - (t (error "Keyword unrecognized by dump object: ~A" o)))) - (defun current-state () "CURRENT-STATE => WORLD-STATE @@ -796,82 +155,35 @@ DESCRIPTION: :ycor (patch-ycor patch))) *patches*))) -(defun export-turtles () - (append - (list - "\"TURTLES\"" - (format nil "~A~A~{,\"~A\"~}" - "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\"," - "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\"" - (mapcar #'string-downcase *turtles-own-vars*))) - (mapcar - (lambda (turtle) - (format nil - "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"false\",\"~A\",~A~{,\"~A\"~}" - (dump-object (turtle-who turtle)) - (dump-object (turtle-color turtle)) - (dump-object (turtle-heading turtle)) - (dump-object (turtle-xcor turtle)) - (dump-object (turtle-ycor turtle)) - (dump-object (turtle-shape turtle)) - (dump-object (turtle-label turtle)) - (dump-object (turtle-label-color turtle)) - (dump-object (turtle-breed turtle)) - (dump-object (turtle-size turtle)) - "\"1\",\"\"\"up\"\"\"" - (mapcar #'dump-object (mapcar (lambda (var) (agent-value-inner turtle var)) *turtles-own-vars*)))) - *turtles*))) - -(defun export-patches () - (append - (list - "\"PATCHES\"" - (format nil "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"~{,\"~A\"~}" - (mapcar #'string-downcase *patches-own-vars*))) - (mapcar - (lambda (patch) - (format nil - "\"~A\",\"~A\",\"~A\",\"\"\"\"\"\",\"9.9\"~{,\"~A\"~}" - (dump-object (patch-xcor patch)) - (dump-object (patch-ycor patch)) - (dump-object (patch-color patch)) - (mapcar #'dump-object (mapcar (lambda (var) (agent-value-inner patch var)) *patches-own-vars*)))) - *patches*))) +; These match netlogo's dump +(defgeneric dump-object (o)) -(defun export-world () - "EXPORT-WORLD => WORLD-CSV +(defmethod dump-object ((n double-float)) + (multiple-value-bind (int rem) (floor n) + (if (eql 0d0 rem) + (format nil "~A" int) + (let + ((output (format nil "~D" n))) + ; Someday we'll have d, but this is not that day! + (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-"))))) -ARGUMENTS AND VALUES: +(defmethod dump-object ((o string)) (format nil "~A" (cl-ppcre:regex-replace-all "\"" (format nil "~S" o) "\"\""))) - WORLD-CSV: A string, the csv of the world +(defmethod dump-object ((o (eql t))) "true") +(defmethod dump-object ((o (eql nil))) "false") -DESCRIPTION: +(defmethod dump-object ((o list)) + (cond + ((agentset-p o) (format nil "(agentset, ~A ~A)" (dump-object (count o)) (string-downcase (agentset-breed o)))) + (t (format nil "[~{~A~^ ~}]" (mapcar #'dump-object o))))) - Dumps out a csv matching NetLogo's export world. +(defmethod dump-object ((o patch)) + (format nil "(patch ~A ~A)" (dump-object (patch-xcor o)) (dump-object (patch-ycor o)))) - This is useful for serializing the current state of the engine in order - to compare against NetLogo or to reimport later. Contains everything needed - to boot up a NetLogo instance in the exact same state." - (let - ((ordered-globals (sort (copy-list *globals*) #'string< :key (lambda (global) (symbol-name (car global)))))) - (format nil "~{~A~%~}" - (list - (format nil "~S" "RANDOM STATE") - (format nil "~S" (clnl-random:export)) - "" - (format nil "~S" "GLOBALS") - (format nil "~A~A~{\"~A\"~^,~}" - "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\"," - "\"nextIndex\",\"directed-links\",\"ticks\"," - (mapcar #'string-downcase (mapcar #'car ordered-globals))) - (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"~A\"~{,\"~A\"~}" - (min-pxcor) (max-pxcor) (min-pycor) (max-pycor) *current-id* (dump-object (or *ticks* -1d0)) - (mapcar #'dump-object (mapcar #'funcall (mapcar #'cadr ordered-globals)))) - "" - (format nil "~{~A~^~%~}" (export-turtles)) - "" - (format nil "~{~A~^~%~}" (export-patches)) - "" - (format nil "~S" "LINKS") - "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\"" - "")))) +(defmethod dump-object ((o turtle)) (format nil "(turtle ~A)" (dump-object (turtle-who o)))) +(defmethod dump-object ((o (eql :nobody))) (format nil "nobody")) +(defmethod dump-object ((o (eql :turtles))) (format nil "{all-turtles}")) +(defmethod dump-object ((o symbol)) + (cond + ((find o *breeds* :key #'car) (format nil "{breed ~(~A~)}" o)) + (t (error "Keyword unrecognized by dump object: ~A" o)))) diff --git a/src/main/nvm/package.lisp b/src/main/nvm/package.lisp new file mode 100644 index 0000000..be93060 --- /dev/null +++ b/src/main/nvm/package.lisp @@ -0,0 +1,34 @@ +(defpackage #:clnl-nvm + (:use :common-lisp) + (:shadow #:random #:count) + (:export + ; API as used by transpiled NetLogo programs + + ; base + #:with-stop-handler + + ; nvm + #:agent-value #:create-world #:current-state #:lookup-color + + ; turtles + #:create-turtles #:die #:hatch #:forward #:random-xcor #:random-ycor #:set-default-shape #:setxy + #:turtles-here #:turn-right #:turn-left + + ; agentset + #:count #:of #:one-of #:patches #:turtles #:with + + ; controlflow + #:ask #:stop + + ; world + #:clear-all #:display #:reset-ticks #:tick #:ticks + + ; inout + #:export-world #:show + + ; math + #:random #:random-float) + (:documentation + "CLNL NVM + +NetLogo Virtual Machine: the simulation engine.")) diff --git a/src/main/nvm/turtles.lisp b/src/main/nvm/turtles.lisp new file mode 100644 index 0000000..cdaa2c7 --- /dev/null +++ b/src/main/nvm/turtles.lisp @@ -0,0 +1,250 @@ +(in-package #:clnl-nvm) + +(defun create-turtles (n &optional breed fn) + "CREATE-TURTLES N &optional BREED FN => RESULT + +ARGUMENTS AND VALUES: + + N: an integer, the numbers of turtles to create + BREED: a breed + FN: A function, applied to each turtle after creation + RESULT: undefined + +DESCRIPTION: + + Creates N new turtles at the origin. + + New turtles have random integer headings and the color is randomly selected + from the 14 primary colors. If FN is supplied, the new turtles immediately + run it. If a BREED is supplied, that is the breed the new turtles are set + to. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles" + (let + ((new-turtles (loop :repeat n :collect (create-turtle breed)))) + (when fn (ask (list->agentset new-turtles :turtles) fn)))) + +(defun die () + "DIE => RESULT + +ARGUMENTS AND VALUES: + + RESULT: undefined, commands don't return + +DESCRIPTION: + + The turtle or link dies + + A dead agent ceases to exist. The effects of this include: + - The agent will not execute any further code. + - The agent will disappear from any agentsets it was in, reducing the size of those agentsets by one. + - Any variable that was storing the agent will now instead have nobody in it. + - If the dead agent was a turtle, every link connected to it also dies. + - If the observer was watching or following the agent, the observer's perspective resets. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#die" + (when (not (turtle-p *self*)) (error "Gotta call die in turtle scope, dude (~A)" *self*)) + (setf (turtle-who *self*) -1) + (setf *turtles* (remove *self* *turtles*)) + (let + ((patch (patch-at (turtle-xcor *self*) (turtle-ycor *self*)))) + (setf (patch-turtles patch) (remove *self* (patch-turtles patch)))) + (error (make-condition 'death))) + +(defun hatch (n &optional fn) + "HATCH N &optional FN => RESULT + +ARGUMENTS AND VALUES: + + N: an integer, the numbers of turtles to hatch + FN: A function, applied to each turtle after creation + RESULT: undefined + +DESCRIPTION: + + The turtle in *self* creates N new turtles. Each new turtle inherits of all its + variables, including its location, from self. + + If FN is supplied, the new turtles immediately run it. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#hatch" + (when (not (turtle-p *self*)) (error "Can only hatch from turtle scope")) + (let + ((new-turtles (loop :repeat n :collect (create-turtle nil *self*)))) + (when fn (ask (list->agentset new-turtles :turtles) fn)))) + +(defun forward (n) + "FORWARD N => RESULT + +ARGUMENTS AND VALUES: + + N: a double, the amount the turtle moves forward + RESULT: undefined + +DESCRIPTION: + + Moves the current turtle forward N steps, one step at a time. + + This moves forward one at a time in order to make the view updates look + good in the case of a purposefully slow running instance. If the number + is negative, the turtle moves backward. + + If the current agent is not a turtle, it raises an error. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#forward" + (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*)) + (labels + ((internal (i) + (cond + ((< (abs i) 3.2e-15) nil) + ((< (abs i) 1d0) (jump i)) + (t (jump (if (> i 0d0) 1d0 -1d0)) (internal (- i (if (> i 0d0) 1d0 -1d0))))))) + (internal n))) + +(defun jump (n) + (when (not (turtle-p *self*)) (error "Gotta call jump in turtle scope, dude (~A)" *self*)) + (with-patch-update *self* + (setf + (turtle-xcor *self*) + (wrap-x *topology* + (+ (turtle-xcor *self*) (* n (using-cached-sin (turtle-heading *self*)))))) + (setf + (turtle-ycor *self*) + (wrap-y *topology* + (+ (turtle-ycor *self*) (* n (using-cached-cos (turtle-heading *self*)))))))) + +(defun random-xcor () + "RANDOM-XCOR => RANDOM-NUMBER + +ARGUMENTS AND VALUES: + + RANDOM-NUMBER: a float, the random result + +DESCRIPTION: + + Returns a random floating point number in the allowable range of turtle + coordinates along the x axis. + + These range from min-pxcor - 0.5 (inclusive) to max-pxcor + 0.5 (exclusive) + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-cor" + (let + ((min (- (min-pxcor) 0.5d0)) + (max (+ (max-pxcor) 0.5d0))) + (+ min (clnl-random:next-double (- max min))))) + +(defun random-ycor () + "RANDOM-YCOR => RANDOM-NUMBER + +ARGUMENTS AND VALUES: + + RANDOM-NUMBER: a float, the random result + +DESCRIPTION: + + Returns a random floating point number in the allowable range of turtle + coordinates along the y axis. + + These range from min-pycor - 0.5 (inclusive) to max-pycor + 0.5 (exclusive) + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-cor" + (let + ((min (- (min-pycor) 0.5d0)) + (max (+ (max-pycor) 0.5d0))) + (+ min (clnl-random:next-double (- max min))))) + +(defun set-default-shape (breed shape) + "SET-DEFAULT-SHAPE BREED SHAPE => RESULT + +ARGUMENTS AND VALUES: + + BREED: a valid breed + SHAPE: a string + RESULT: undefined + +DESCRIPTION: + + Specifies a default initial shape for a BREED. When a turtle, or it changes breeds, + its shape is set to the given shape. + + SET-DEFAULT-SHAPE doesn't affect existing agents, only agents you create afterwards. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#set-default-shape" + (when (not (breed-p breed)) (error "Need a valid breed")) + (setf (breed-default-shape breed) shape)) + +(defun setxy (x y) + "SETXY X Y => RESULT + +ARGUMENTS AND VALUES: + + X: a double + Y: a double + RESULT: undefined + +DESCRIPTION: + + Sets the x-coordinate and y-coordinate for the turle. Equivalent to + set xcor x set ycor y, except it happens in one step inside of two. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#setxy" + (when (not (turtle-p *self*)) (error "Gotta call setxy in turtle scope, dude (~A)" *self*)) + (setf (turtle-xcor *self*) (wrap-x *topology* x)) + (setf (turtle-ycor *self*) (wrap-y *topology* y))) + +(defun turtles-here (&optional breed) + "TURTLES-HERE => TURTLES + +ARGUMENTS AND VALUES: + + TURTLES: an agentset + +DESCRIPTION: + + Returns the agentset consisting of all the turtles sharing the patch + with the agent in by *self* + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles-here" + (when (not (turtle-p *self*)) (error "Gotta call turtles-here with a turtle")) + (let + ((patch-turtles (patch-turtles (patch-at (turtle-xcor *self*) (turtle-ycor *self*))))) + (list->agentset + (if breed (remove breed patch-turtles :key #'turtle-breed :test-not #'eql) patch-turtles) + (or breed :turtles)))) + +(defun turn-right (n) + "TURN-RIGHT N => RESULT + +ARGUMENTS AND VALUES: + + N: a double, the amount the turtle turns + RESULT: undefined + +DESCRIPTION: + + The turtle turns right by number degrees. (If number is negative, it turns left.) + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right" + (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*)) + (let + ((new-heading (+ (turtle-heading *self*) n))) + (setf (turtle-heading *self*) + (cond + ((< new-heading 0) (+ (mod new-heading -360) 360)) + ((>= new-heading 360) (mod new-heading 360)) + (t new-heading))))) + +(defun turn-left (n) + "TURN-LEFT N => RESULT + +ARGUMENTS AND VALUES: + + N: a double, the amount the turtle turns + RESULT: undefined + +DESCRIPTION: + + The turtle turns left by number degrees. (If number is negative, it turns right.) + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right" + (turn-right (- n))) diff --git a/src/main/nvm/world.lisp b/src/main/nvm/world.lisp new file mode 100644 index 0000000..6dfa214 --- /dev/null +++ b/src/main/nvm/world.lisp @@ -0,0 +1,100 @@ +(in-package #:clnl-nvm) + +(defun clear-patches () + (setf + *patches* + (loop + :for y :from (max-pycor) :downto (min-pycor) + :append (loop + :for x :from (min-pxcor) :to (max-pxcor) + :collect (make-patch + :xcor (coerce x 'double-float) + :ycor (coerce y 'double-float) + :color 0d0))))) + +(defun clear-turtles () + (setf *turtles* nil) + (setf *current-id* 0)) + +(defun clear-ticks () + (setf *ticks* nil)) + +(defun clear-all () + "CLEAR-ALL => RESULT + +ARGUMENTS AND VALUES: + + RESULT: undefined + +DESCRIPTION: + + Clears ticks, turtles, patches, globals (unimplemented). + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#clear-all" + (clear-turtles) + (clear-patches) + (clear-ticks)) + +(defun display () + "DISPLAY => RESULT + +ARGUMENTS AND VALUES: + + RESULT: undefined + +DESCRIPTION: + + As of yet, this does nothing. A placeholder method for forced dipslay + updates from the engine. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#display" + nil) + +(defun reset-ticks () + "RESET-TICKS => RESULT + +ARGUMENTS AND VALUES: + + RESULT: undefined + +DESCRIPTION: + + Resets the tick counter to zero, sets up all plots, then updates all plots. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#reset-ticks" + (setf *ticks* 0d0)) + +(defun tick () + "RESET-TICKS => RESULT + +ARGUMENTS AND VALUES: + + RESULT: undefined + +DESCRIPTION: + + Advances the tick counter by one and updates all plots. + + If the tick counter has not been started yet with reset-ticks, an error results. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#tick" + + (when (not *ticks*) (error "reset-ticks must be called")) + (incf *ticks*)) + +(defun ticks () + "TICKS => CURRENT-TICKS + +ARGUMENTS AND VALUES: + + CURRENT-TICKS: A positiv double, representing the current number of ticks + +DESCRIPTION: + + Reports the current value of the tick counter. The result is always a number and never negative. + + If the tick counter has not been started yet with reset-ticks, an error results. + + See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ticks" + (when (not *ticks*) (error "reset-ticks must be called")) + *ticks*) diff --git a/src/main/package.lisp b/src/main/package.lisp index 443f85d..8bafc43 100644 --- a/src/main/package.lisp +++ b/src/main/package.lisp @@ -64,44 +64,6 @@ the nvm in the same way that comes out of this transpiler All the code to convert the list of tokens coming from the lexer into an ast that can be transpiled later.")) -(defpackage #:clnl-nvm - (:use :common-lisp) - (:shadow #:random #:count) - (:export #:export-world #:create-world #:current-state #:with-stop-handler - ; API as used by transpiled NetLogo programs - #:agent-value - #:ask - #:clear-all - #:count - #:create-turtles - #:die - #:display - #:hatch - #:of - #:forward - #:lookup-color - #:one-of - #:patches - #:reset-ticks - #:random - #:random-float - #:random-xcor - #:random-ycor - #:set-default-shape - #:setxy - #:show - #:stop - #:turtles - #:turtles-here - #:tick - #:ticks - #:turn-right #:turn-left - #:with) - (:documentation - "CLNL NVM - -NetLogo Virtual Machine: the simulation engine.")) - (defpackage #:clnl-lexer (:use :common-lisp) (:export #:lex) -- 2.25.1 From 6fc4a1700ede4beee1d2a547d75be6b40488a1f5 Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Sun, 29 May 2016 22:53:54 -0500 Subject: [PATCH 14/16] Code reformat - Macro for functions implement commands to return :undefined --- .travis.yml | 2 +- bin/buildtravisexec.sh | 2 +- deps/common-lisp/docgen_0.2.tar.gz | Bin 6447 -> 0 bytes deps/common-lisp/docgen_0.3.tar.gz | Bin 0 -> 6435 bytes src/main/main.lisp | 3 ++- src/main/nvm/base.lisp | 3 +++ src/main/nvm/controlflow.lisp | 10 +++---- src/main/nvm/inout.lisp | 5 ++-- src/main/nvm/nvm.lisp | 4 +-- src/main/nvm/turtles.lisp | 41 ++++++++++++++++------------- src/main/nvm/world.lisp | 24 ++++++----------- 11 files changed, 47 insertions(+), 47 deletions(-) delete mode 100644 deps/common-lisp/docgen_0.2.tar.gz create mode 100644 deps/common-lisp/docgen_0.3.tar.gz diff --git a/.travis.yml b/.travis.yml index fa44e4a..d52b800 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,7 +6,7 @@ addons: before_install: - export DISPLAY=:99.0 - /sbin/start-stop-daemon --start --quiet --pidfile /tmp/custom_xvfb_99.pid --make-pidfile --background --exec /usr/bin/Xvfb -- :99 -ac -screen 0 1280x1024x24 - - wget http://frank.kank.net/travissbcl/clnl/72aabe5/$(git rev-parse HEAD)/travissbcl + - wget http://frank.kank.net/travissbcl/clnl/31bdd7b/$(git rev-parse HEAD)/travissbcl - chmod +x travissbcl script: - ./travissbcl --script bin/all.lisp diff --git a/bin/buildtravisexec.sh b/bin/buildtravisexec.sh index a7757e2..5f8b14b 100755 --- a/bin/buildtravisexec.sh +++ b/bin/buildtravisexec.sh @@ -26,7 +26,7 @@ mkdir -p tmp/deps/ tar zxf ../../deps/common-lisp/trivial-features_0.8.tar.gz && tar zxf ../../deps/common-lisp/cl-charms-9bb94ef.tar.gz && tar zxf ../../deps/common-lisp/style-checker_0.1.tar.gz && - tar zxf ../../deps/common-lisp/docgen_0.2.tar.gz && + tar zxf ../../deps/common-lisp/docgen_0.3.tar.gz && tar zxf ../../deps/common-lisp/ieee-floats-92e481a.tar.gz && tar zxf ../../deps/common-lisp/strictmath_0.1.tar.gz ) diff --git a/deps/common-lisp/docgen_0.2.tar.gz b/deps/common-lisp/docgen_0.2.tar.gz deleted file mode 100644 index d1cc757d6c6ffe3a39cbc550d6e5a37476a8a934..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6447 zcmV+~8PMh*iwFR}X&F}l1MNL)bK6Fe{>)!71;sI`2wG8+ATAeMsRIweGC1*Dm z#|cCZMVv^20YJ+-$NKHp-SZv{K+4bT9*~Mf0y8~5-97!99%7UY&-whfo$cMf-TGA5 z4qW%{-o?NDdv|y2zv{Zx-@UhUuzRq7aPQu&o&IkB-rg;C_mg2{UCW|Oa>i~=cz%}h z`gW_H|C?ST!+-H{dzu!Dk2?l3_+Wp(hX4Kk{yoEg_zV2s-|O$+VmlufjqvsVod4Z) z9xsyNMRLyB#z2TbuhZ#{_&A;Oc$m#cX_;no_BxrSqXa+3<0PFfbI#`Jly$qa;+zfA zc?x8N5A-eP$%yBHE-^gr^*XGJBQ0lqUeaS0y(svIrSp>K^JF@`V&g1l0vWbQ^0HuM z#)|YD9rl?AZ^G*mvKvhlj_HUpzlL>A;BU^FV#tG&cu8WW}hHpP&2}dvfv!hCO`#=*5$x zr>7_E@aY2vgS>$52n)au*dbGBAoAH1?qlBpJE5{64ov{^fIZsS8)t$T$yv56slP<3(|K@oa{u}9v(w`rpArU@8JEcgF8~TnJ(-U* zu|OOqNy$J`2qJ$Yy@L_xI8&urXxND$u72_TUwM`1bCRt*%?PsLpg+A z@MQ@f0TN0gf3wK)5~j3`c>XvC0nO%I2p?O3q>F*sWeONU*PLT}fP_f0GM(`)LKbK< z1oY=gNuwa14AgCjbHs@xFc?Q<0aa*$)Z30gcxTBl&!)U2A-hb=Nn9+4Lm+r8m_bs` zzRo#-8lxyO_Iq~%6Pxlp9wr5+ThMutXXkUa^^Y-#u7J=}j{@tv`?|-vgrAnAEgC7% z7*{rX-J=W96xaf~*r7mGLH8M~ky!C7mi&_Vqu>LI%VHvy4)v713SN%I4fqVSm7h0o zH3DD$&IT9!3cnJ>c%IC-> zr1nk+t*vwqy3^D}sYBfZZZxz9(uhR?WVo=c$DM$9k*(+o6+yNnl3M2akWCVh8E^4M za=f0Qwvv&atx^{`FUzZV0fJG+zJ3My5$goFhQc2`dwz6!`g8p3`SH`!*jGU(a#4W- zIzi=o^5XveqmvV z^Lc^dLMq?Y=CUKmCC^c(qC!QDJB2UcKfu2*$kD$JpFDdk8PZ)L90L%GKK;AfLxz{A ze)(&jUqR=MJ77FOIhXjwTIhO}3)9Vv`a=b%Y1ggTdZ9TQ6^HC?bcb9oC5w*dxKal2 z&z46Qu?EN4ay}Yd-)7L_`gSDLS;28pDu#l-EhlMizUzghuvXZi)arYp6|Ep^-Ib^) z;%tn|9*i6?PZGpg;~N|7zI=Xt8~%HH{dSXWZo*7{xjy{0yK#Nk+uUR^;`|OCzl;7- z*2H2`NVl(4+(v6_hNAf~n%`FCpkm|i(P22x@+-n(Jyl-?QcPf$9|Qq>ri%|7eZ-4l zBZQtIlD1UMR1)T^flSTzEdVA!s2js@NcEl=IK&FVu&AYsbThHgayO8w$*@;I1juxw z{tk)WV`PUsf&Q92+CR`*O8D}XaO>z_&whM<>IYj-4xj(<;KzSHeUG?Fb;XB5t=ORv zdi%2^zZhkga|{XoPoh6Mu#>R81~uCc%X2k)BT2~1;V zutR5+8cZ@!W`G=@Ey2L5Sxi91<;8*zVU|}@PF5ZK2;kFlit!hC+Dw;5jXp zWn5;l6o4-L6?Q~gMEK4kw9aUs?NEbceKxvb_)!51K&w`nI#ip#g$}Qj#r6D=U>vhL zN~wt-{K#F8|lVbFd$7s&~?(E#% z+co+By?xC8_S^jL=efGT?(qOjV{uiKd?u5w9X2529zAfB?jsRsWjUyb0oas+aDtfPsGiYZ4-~?ij!Q;{yKKhRCspjgw^whJ1~N1qTHJW(z*TEr>Wp zU;%0&1+5ZEB^dRXx`T?q`U<+m`Ua}c`bLZ0`Yz^<$z%o;!3j5(dA9dxp58-eGh#C)m}fFgWpBZ$eXfy zgVU8QRBPRQmZ6pIiIfBVD6--SCoOElI zFOEmc#WWq#UIXqOfhUUIjRlqsFhQkV!SC!CW1QwZR*BF8y-PbQn$9t|HstJ%Aorjy zH%gmjPUOOeWqdXT{ivpI`MXF5%5Mp3$UOYz1l;Sc!0~V2u?RduZ|bg-8-HYFLl(iHw*gVC;wrWa-jU;7px$BGZRH*xvl*F#hjfR}S)nT%0OAn}Keo z&=2CfX?6(&!-!+eA@yit14}J@(XXc4FG>8rtI<4FagLAUaS0zt>fx03HWn$4OoD-X$~hmydI4>EC0EY6W5c*O{0EGU`_0qk zXvN@yrNTU6$PYHHDmex>u!|)q48V>lK$6u6D9CJ;9CzpU3YfXQ3GDo8HRCl88gwd7 zqr&w+Z_06jl@hcnem6w`mK;gmy5lpp&P4U5Spjhh?R_DOGgX;j8LA4auzy#ecPe*>gf!X=1B&VfrY z2eh$_Qv4c~INA15I-)&Ucr=`_m%xD2pPwBK1Sl$lqAl!~k)WqFfj;dr(INmB{2czojowGCQB_k!?VoLmvsWh(?hv?@N zmyGNi)(!(b@d%-1Sce=~85E1fO?}`;Ih9dQHL_6L}7a!1@ngLg~uXPWp`x1 zXzP?%*r*`u#J+~S@wN8w*P0qo(hnh=m_bHZ6ucVeG zy5l)$9b5poQ6qSfu`-!nh$6Qwb_UPRvC0GV3WRO5MR`T4CJ;FY^{Cdqz4UFjN{F=8 zkD=^Yl1Jih`pP)GGGDnWJ?;%h)uuNitn>qeW7?yht6gsqgQ_nMK6=&50mJCYvIT3( zJ-=gR1_DWgszWbX7hwZ5Aj6BqkI{-@o|4?h--EhH&hun3DMXB3iI4|+g_L#-Z-vkz zN+%&vk(&@zvqt1(qKMLw_k}|+rF{#oYYarlZLc94fD?e*0&hjY6#N<~j-=hII8KbA zySn|2JwnB{VL27CW2EK@9SGWntcV-ZZOmU8>}GBfeVi9Ml^nRR3XmxrIkvUk95 zlF+jIF-*hpWCU6~oH+`bRg-PAR(PZMO7rW?NxR#kMmH`oL+WwDH?{mtG6Tn_HVb`7BSJFvt4Pt>= zbUNR%hg4~Z<5Nk9C|;SL7r>?qF8w1Bg6CY#*%te5DO>?NkD1Q@2k}wKcG1Ri0@MR7 zX-X8c`c`s6rExsaQJ7-&hFuNrM;kKOFyR6Mh|`kKdgh)O>(%;$Hu>-MM zj@TdCSBRO8^w=%7(4QgV?cvLodeW+u7%({wOk)x6{@#+w&Z5;|loj}O0^7VV@`;Mvg zQeB3*-9|Nnimf38_I(+>{?^h(zOPf4Lz^pgznW1&5FhIA>udr|#GY9r?W*Mj!3;{Z zn1H4l%MNi zAt+oA=@#8}WkMciZ9AB*TZ|baP$V#1kqt@x-|2QEohpvlHXG<~K(q*pNboNHrSF(7 zp&R(27p%Z>MhkE5J2OZl_OYmJpO8=gqLttYKrN*|n?@i|qoB4B+ z+tu?vyz#ufDR04?O{^@1-7eGe7eaWaL+u9Gi7rz%Zi}}vqf#rU;}~^;lAwi2I?Hsh z(^n;(otwT1RKH;mTh;ogM&PS$PN<}=~5u&WP8NLFp;|zv6Cvbll;zh zhvz6Y_$amG>2ASHu9b^Z!KRzksct8_!qLNU&=(t$8t)e+=$`pS3A^HumamslaSSdV z?+}M60|!@4R>Ub2vr`y7Cv_sy<~UjPRBXOF@wE({T||Dn?gA#g-y-RbmR8QNG50LW ztuN-;rP_Ix2b&0lP{TS{7vgHcuaHW)KjN=Xu8j?*jVm5b-Q4VSHsE3>SHO%ngH8wT z(nK~l+4WmBDR%u1+z9ji`W1K*?>Zf#yVNOqz|b9`VXPbDY?+r6btk}aZ%cZtG)x|- z8B{E$b34Q#eUo(uLUe5^bU|upBG<2A8okI`r$k#xVFY4WIPe)~0r?ZatO>;wvpKK? z&6V)bB;5YWK~w2xqh_K=xQhO&xQz#mn+`n@Xt(3gn?vkCDibp`ij(ogdXbj2d>edsNp~!wYDZ3QUe&P6XcpT8^NepfH!NK0 zM;%YjH1#FSfTWRpfnw306$?xknv(k3(+l0)EL;iG2jAd>qc`X{AD1WY$n_HE4MmKR z$RsMQ-CQoU>W-}5mF;@k)`o8V9+KTuYBZ;%Wzf5IYs2XfvhQwxN6MVO6(irRh=kL= zfxzBTYf0-7A5IfI1%U{;{uf@grCprGL>ip;K!QH)E{oT68I_n=?6D(NlpA_v)x^0`tf}A< zV6B2E4V-p;>8S}wgWG)cqhL+_RI(>!822m2uiNW~Qdhxu@&K?0scbWiLvv!da#8 zs*>c@;!hC#1hHM~q~Gzhj{qvb1Pe3XwY|`3pcd z3r9aK><$`|NK_kGqGpO5m|$i_k9b8}4eqraw=kozbY$>~K8XYk1y_YE+!~3` zpUUa6?EmW|{}T4UzrVA$FMt1GcV}Jp9RD8Y zoMU(QTmh{sBDziKk9E=j8RYq6)}oaaR(^=- z@^K14MXe`BjTOii3gMDE)uS1QpVW__t}fHm0L9pL%xaIN&rdg22f-GEL1YpyuCE|JKS~5&_4f$eu>3~^>Uq!%8Pn7DlgF42)qxd78eRF{u-#zi_F$V zr4|bP`v2#j(wAQF-eu{3BFLwx09m2`_xk&HMg3mB1Cw?gyA)skURS+8EwR0Zhm zEULR&_=-cUe|AT|F1Uv;`%#}&-%`D9-6_zJ6!YpZ*DS=`VAubk(A=)XylvisCQDdV zEv7jXE=w~_ZRQ#o4RPwyg=nV9BK?u-DPX#hmV&xif9)edAuMat7T7tK{SCT}umY(E zeOCUj=kv5zd$m`4wO4z!S9`Trd$m`4wO4z!S9`Trd$m`4wO4z!S9`Trd;OO&>p#8TGVNpTx;{nxvW7={dbk z)6x=T@mdm9lCtBQ#=rgUF5VzW$&E0=|@v*Kg zxbE-ol& zeY<7P|EAZ_@Lzn~oTSD4!;XOrzPGnm!~gB=z59~?_xAVqcaZ;kyF0-Dtq+Sv`1*g& z|86>q=gHtaIpb`tFGQf%>2!yDl+JiO$Y#T|OtTrgNG9np!H@AMNhgb(vspS}-R`tF zWBqiN0vX{0eam?=Xl*{%HV2#r_!U~~j~2ReE?hIAJ3l`IXwgpxPmUfQoE*l_ z4<7t*@c58D|KTzF_B;0I;ONQA7l+3k7*T!ht556ZW*>;G7 zQ(hF<5eQu-AP%!L;3u$gDu|JsW{Z;gOQbrThlj@xUK~9?Ir{M#VNjWInVj=IN`|mrIZBPole0xSMu zfi?p`f0mRq3gXE?-Ih2z;iGYpXx5JG%W3&rpmbyoac zf{j5p4)uyfyv3{$+BBIDl3Y=Bl1xvBiB?1MZeT2Ipq_)a0-mw1tI8Y@3|F^QCmKh* zVUVQuP6w^6bPu}I)J3U7-2-kkv4<$L_{!Gpu&W2rAe@50~p2Bj+7_u0S492R)afHbpAXf7rE^Q1tfV+d5Mj4K** z3GPCF67Hzv^2MyMZ6|7Fz#|)>?wM`^yrYs07t^`0wk7mQa!~Q0wfQC3KVGK3Ys95lEMwjMGAC--Yl2SeYjma2M3P zu={*gptz9AceT0f2y)4D)TyXYQR7bF3-}N47X~@}&%x8@Pb5RSON65jVzEtscY4V1 z64fui;Q1AFUb_p%1C(=#U#x|$SGh3V%&0$9fSPvQimex#qfv3l-bQ!G^-{9vXof4L z4}Ug1x`;J6$`-R>|N0Jt7T0$oq0S19i&8NZ^ldp#bMsv>pSq@+v~UMY<(SO^2_zXuidrlgWmc&ixKB{@c3Qy zm$D`nlR~qQy43V^@YNnDfUkzkxwr>G20YcpvhC`}bV&D)f2*aY5GSbb&Ld)GiswTr;0TCe6 zjruzzy2Z#2c>?`4d9;6^wUqGXE8*7Rf1dyN;=~WOo*umT;o*<}es+tvNp;1CLao@L z5qkU6BtIW!mop3(K&xu)O$IqFm^Mm|a<6&;9_p2-35Ep&2I^SFORllN00-}y;0a7) zX0StNl^TpQP-cJ}pDw__s#%Od#pT7E4`7y86HZng{0QLFVuJA@cm)^{0p*hsT4n5` zh=pF>Dd#2%9&Shv1AL;zRK|H|)d6!CYiI*nw$LFLL7-qs#YwKIxRs^2wV@CmK6p;^ zMH!b_ECrwo{|Y-IEh2np5n5-o&vvLmvOXQ&F#M>11)x={OdYDt-$IAi%Hn$dNHC6B z9;MX85B}sr3)p}NhdDlspg}P}>OvnMOpU6QkW94E`P_NC4|P@ZzezFtz+*J$f48>w zcXxFDfA8Kd=6|=h_uBmLr?|Sn?ol61V{uiKd@7T!9o8q~9zArF?qd;XWjUybKG>9k za^1Z=xZr^^cVM2)jSa*8lD{?)iE9KU+In z?fU-|S7`r-jH&dPVg0amxV_#pU%^|wh%t#SZ(`1kb8zT;=o6^+`q>QpE_z1Zl+_!Y zu57Ma>*mu8t#nVM9O#eVLPNl24mJiy@XIc+tnn!e@lA{{8dC8#0u@Rwt7ue$=re|*a#@CcC~puoB|mUf2bkjCLd zMk6sAiF|iVHAO^yH{lAFARR$C32-G|U!hx^&2dV}#MyqsfJ8lzEJlU{I97^HH0$09 zIQrN*1P}m~((V^%WFqz@wgP!=g8v{v-3}H&3_vkZ!U|X^T#Z8zb=HYYA9{at{g;FIzkXdh$PaRHs_<+Ix|u>h zi0>xZB@hfFjunU0qlpbHweUs1nr^=&@&7DG^F+ltK8}m|yaC5jp+Y>A&qN#sp$06W z;#{)VVwzaK9-6OSt$!(@+gn(D1x9UYRmGuLoEH2K>dHV~w_`1{3LlM=3~2>MAciWj zO(Q9IHRE7&1t-fZFlr|CXT)@ynnu68dewdPs`smCSr^mE;Mq9fYxb*$S^cO76WZIDr#LbR2JR{6d<5$SwCR;xIjfEh|6aiRrBzdcj&)6yx)thDo#3{7*g)GigWrAg>Dy){%=v$v}#P~?7 z5dh7$9WA27p;84v77Hhc;h}*E|Kom`dJw&awjlHUU%&44S$FemAiWYUK`e3(T#7lM zjb)VL*QmtFwhz-G?a9KU!I-@Q2Aur-{ID-TQ5h6%VZVw5J*^Q0Vj7#ApQWgQSiGPDNM%8sFC!Vt$t6>8L|fMiyh`0g4IanDxZmO^$&>5kOo4`DVJWqOpJ zp?`{-!sG0c3TzaNW_d$Aw@`TMUroX9Z@BPk|M0<`c}R412nnY^0C?pq0Qt+@>K4+v_NpH&ib?7NIJ;Bl|^L zr^LcW1z9KdHRO%2w1>aa)PRzH2;syGGQy(ZMLF&gJ0HHR>F(L!HbNQ$>dxVxoxmhcy@+W9-vnsY@5!@D^fLq$U&$_wf60$Z@X1Oq^*7o zWzUj45_i*A#^IIu%2nxcZ!oMjy%}Mp9~d0d9`#J^dW#rTeR1&7t6mNmMo*S4SX1u# z9V;^sNE%cfdda#78=wIhUL<~uRt)l#kN{YhrLRl7ef9s3Rn| zf?3bYoYXY~+M!Pwf`;dT+8|<+t4WEYj6@-ESyC>wZ+I~ zz2vafumHj}yMBA`?A0Nb`0NUj0Mla?T6qgnaoOvq7L?DzfXIiqYvkQt;wuZg?sQv8C%H9<1!mFd ze8V15r6G<_B_X1CWp-8oo6foPk39K z#eDr^k-?Ij@-m4jS?qgTda}Kh2Q(#Owux5QP`EEym|8E@ zWtiJ-R3oU^8bV;-m(lBQC0*qEI(0d;nNs)585IQazW%<>CeTFenKja`T22tmpj3+q zXsW@?p4#mTk+~MlDx1dQkZxBLdxVVw%zmAwkBwx#w^i%PsIS~FT&DHBz`eVxj$S7l+3$pPal~-yjJ= zoR~Fp+fXc5hJ^_qG|F0t>$V%k2DBkYvvGZ-N@EE>S#o{KX+N4aqs?BlOc&AfYkrpZa31Y;)rdszWxS8i?E0U@8ZAo9n&Rr z13&bF6*$gl;mv&q$5o7GO6RNs)Ky#k#};`BzKcld-xG8QY^6<|H8wRmet&eI1zS`!5O4_OfdG%@*VN*9oqV;Om&EcU2anls8>4OfzEhee# zRrcJm0MY<3D=%g9z}gTY%8Fis?!mDtJ3ZpJB!+rie*>#-i*E^jxxY+R( zFyl?X(}BA*k@atiUB3ed!+gJf4L-)ZPKW3&wT&JybVukO>&7Ts;a-SD`kw#O2vRgEA&eg^RAe6H`#`5vaE1Rw4g2y4w>8<262Tk* zL9SWxaU6rEp(a{wZHKSssk4}?;Z9}Nbz6?X**-MS?MaFQa+aJ{5%f3nJSa6j$*47yTx}$34ts;vD%KF;>3M4Q=peYZ`aF zpG)*>e>SQsCn!{wJ}+7rfoHVWge!dRAOSW$Bsu) zZs?I!6X(XNrh-d=wF;s%aN6~yrzY$SZu8NPf;IJ1$&ygDnuUc|#%b4>nVK@^o~|3S z_mx$Zy(qm3XO+UMN|INLKSA&l#CENdnzLxA973^py;E=_%Dp>fO>T+dBiTUyj)iK- z(xPE0MDCbmpMh=`j(%F$9W*47s5Y=f%@jGx<868{!OV&t@rt$@++aJtU`AtU5B@cM z5@{F;f(luEZ)y}OU9Uo%>enJk z5Vt;oa3k3kY}2{e_Ao+w7@<9k&>lu;4T&ZQRI@kQfLz>E4|QLfL2ym z`5~suhbaIRwVoI?Rv=p_giGpFk7gWxQa^&ayi8LA6l2>lt38%JKiya%tbcsfhT2f5 zhBWweb!sZ5W{HfD80OS>S=C!z&smG8v|F5Bh;X`CgGPaRboA`#>Z`n~M{m#8A-`XErGqIxwItJF=ktx~ytmC7CY{|c2VW?kA% zEd@s^2!E?6s`OOKuCDKqP-CJ}%kS>!xHhU*m&gYY4z+-d-@K^mR6)m+$P};4nYH6?cz3loQu?_U$_W+mF|7`Ey z+xCC|d2jz-yZ`qoE>s}?{vYf17X`;(J4YST7jH~~r=0$1|_P$8F{&dY+Uo8ZgoqJ_Yl!Gs%H;5*K^_jXA0ZpcnT?FOavdZ@5jz7?{_ z1lV#6I#K@CqIjPNvtN!PI&QGbaXR6hNtT_X#|6d<4~~(8Pj5BDlr&5z!8fN(sRX8& zt7NKqdui}@xa*jqef~B55{otK^_{ix5XZ>e6l?i6T9ig|UID;8p|vFqU-<}52+P{E1$K^Qe}ir#tU&5PpOydX`8@5_UhUOh x?bTlG)n4t@UhUOh?bTlG)n4t@UhUOh?bTlG)n4t@UjJ9G{{@g8wL$=(004D4euMx3 literal 0 HcmV?d00001 diff --git a/src/main/main.lisp b/src/main/main.lisp index 5bb9361..a226642 100644 --- a/src/main/main.lisp +++ b/src/main/main.lisp @@ -126,7 +126,8 @@ DESCRIPTION: (if (getf prim :macro) ; The reason we do this is because with macros, we want to evaluate them in ; this scope while preserving them for the generational purposes below (append (list :macro (eval (getf prim :macro))) prim) - prim)) prims)))))) + prim)) prims))) + :undefined))) (defun model->single-form-lisp (model &key (seed 15) initialize-interface netlogo-callback) (multiple-value-bind diff --git a/src/main/nvm/base.lisp b/src/main/nvm/base.lisp index 7fec1df..1a80dc3 100644 --- a/src/main/nvm/base.lisp +++ b/src/main/nvm/base.lisp @@ -38,6 +38,9 @@ DESCRIPTION: (stop (s) (declare (ignore s)) :stop) (death (d) (declare (ignore d)) :death))) +(defmacro defcommand (name args docstring &rest body) + `(defun ,name ,args ,docstring ,@body :undefined)) + (defstruct turtle who breed color heading xcor ycor (label "") label-color size shape own-vars) (defstruct patch color xcor ycor own-vars turtles) diff --git a/src/main/nvm/controlflow.lisp b/src/main/nvm/controlflow.lisp index a1df63b..b4368fd 100644 --- a/src/main/nvm/controlflow.lisp +++ b/src/main/nvm/controlflow.lisp @@ -1,14 +1,14 @@ (in-package #:clnl-nvm) -(defun ask (agent-or-agentset fn) +(defcommand ask (agent-or-agentset fn) "ASK AGENT-OR-AGENTSET FN => RESULT AGENT-OR-AGENTSET: AGENT | AGENTSET + RESULT: :undefined ARGUMENTS AND VALUES: FN: a function, run on each agent - RESULT: undefined, commands don't return AGENT: a NetLogo agent AGENTSET: a NetLogo agentset @@ -35,12 +35,10 @@ DESCRIPTION: (t (error "Ask requires an agentset or agent but got: ~A" agent-or-agentset)))) -(defun stop () +(defcommand stop () "STOP => RESULT -ARGUMENTS AND VALUES: - - RESULT: undefined + RESULT: :undefined DESCRIPTION: diff --git a/src/main/nvm/inout.lisp b/src/main/nvm/inout.lisp index 7a78cf2..b8f88d4 100644 --- a/src/main/nvm/inout.lisp +++ b/src/main/nvm/inout.lisp @@ -80,13 +80,14 @@ DESCRIPTION: "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\"" "")))) -(defun show (value) +(defcommand show (value) "SHOW VALUE => RESULT + RESULT: :undefined + ARGUMENTS AND VALUES: VALUE: a NetLogo value - RESULT: undefined DESCRIPTION: diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp index 7927909..e3f582d 100644 --- a/src/main/nvm/nvm.lisp +++ b/src/main/nvm/nvm.lisp @@ -76,7 +76,7 @@ DESCRIPTION: ((= i (length copy)) (incf i) (car (last copy))) (t (let ((result agent)) (fetch) result))))))) -(defun create-world (&key dims globals turtles-own-vars patches-own-vars breeds) +(defcommand create-world (&key dims globals turtles-own-vars patches-own-vars breeds) "CREATE-WORLD &key DIMS GLOBALS TURTLES-OWN-VARS PATCHES-OWN-VARS BREEDS => RESULT DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX) @@ -84,11 +84,11 @@ DESCRIPTION: TURTLES-OWN-VARS: TURTLES-OWN-VAR* PATCHES-OWN-VARS: PATCHES-OWN-VAR* BREEDS: BREED* + RESULT: :undefined GLOBAL: (GLOBAL-NAME GLOBAL-ACCESS-FUNC) ARGUMENTS AND VALUES: - RESULT: undefined XMIN: An integer representing the minimum patch coord in X XMAX: An integer representing the maximum patch coord in X YMIN: An integer representing the minimum patch coord in Y diff --git a/src/main/nvm/turtles.lisp b/src/main/nvm/turtles.lisp index cdaa2c7..49c1834 100644 --- a/src/main/nvm/turtles.lisp +++ b/src/main/nvm/turtles.lisp @@ -1,14 +1,15 @@ (in-package #:clnl-nvm) -(defun create-turtles (n &optional breed fn) +(defcommand create-turtles (n &optional breed fn) "CREATE-TURTLES N &optional BREED FN => RESULT + RESULT: :undefined + ARGUMENTS AND VALUES: N: an integer, the numbers of turtles to create BREED: a breed FN: A function, applied to each turtle after creation - RESULT: undefined DESCRIPTION: @@ -24,12 +25,10 @@ DESCRIPTION: ((new-turtles (loop :repeat n :collect (create-turtle breed)))) (when fn (ask (list->agentset new-turtles :turtles) fn)))) -(defun die () +(defcommand die () "DIE => RESULT -ARGUMENTS AND VALUES: - - RESULT: undefined, commands don't return + RESULT: :undefined DESCRIPTION: @@ -51,14 +50,15 @@ DESCRIPTION: (setf (patch-turtles patch) (remove *self* (patch-turtles patch)))) (error (make-condition 'death))) -(defun hatch (n &optional fn) +(defcommand hatch (n &optional fn) "HATCH N &optional FN => RESULT + RESULT: :undefined + ARGUMENTS AND VALUES: N: an integer, the numbers of turtles to hatch FN: A function, applied to each turtle after creation - RESULT: undefined DESCRIPTION: @@ -73,13 +73,14 @@ DESCRIPTION: ((new-turtles (loop :repeat n :collect (create-turtle nil *self*)))) (when fn (ask (list->agentset new-turtles :turtles) fn)))) -(defun forward (n) +(defcommand forward (n) "FORWARD N => RESULT + RESULT: :undefined + ARGUMENTS AND VALUES: N: a double, the amount the turtle moves forward - RESULT: undefined DESCRIPTION: @@ -153,14 +154,15 @@ DESCRIPTION: (max (+ (max-pycor) 0.5d0))) (+ min (clnl-random:next-double (- max min))))) -(defun set-default-shape (breed shape) +(defcommand set-default-shape (breed shape) "SET-DEFAULT-SHAPE BREED SHAPE => RESULT + RESULT: :undefined + ARGUMENTS AND VALUES: BREED: a valid breed SHAPE: a string - RESULT: undefined DESCRIPTION: @@ -173,14 +175,15 @@ DESCRIPTION: (when (not (breed-p breed)) (error "Need a valid breed")) (setf (breed-default-shape breed) shape)) -(defun setxy (x y) +(defcommand setxy (x y) "SETXY X Y => RESULT + RESULT: :undefined + ARGUMENTS AND VALUES: X: a double Y: a double - RESULT: undefined DESCRIPTION: @@ -212,13 +215,14 @@ DESCRIPTION: (if breed (remove breed patch-turtles :key #'turtle-breed :test-not #'eql) patch-turtles) (or breed :turtles)))) -(defun turn-right (n) +(defcommand turn-right (n) "TURN-RIGHT N => RESULT + RESULT: :undefined + ARGUMENTS AND VALUES: N: a double, the amount the turtle turns - RESULT: undefined DESCRIPTION: @@ -234,13 +238,14 @@ DESCRIPTION: ((>= new-heading 360) (mod new-heading 360)) (t new-heading))))) -(defun turn-left (n) +(defcommand turn-left (n) "TURN-LEFT N => RESULT + RESULT: :undefined + ARGUMENTS AND VALUES: N: a double, the amount the turtle turns - RESULT: undefined DESCRIPTION: diff --git a/src/main/nvm/world.lisp b/src/main/nvm/world.lisp index 6dfa214..5bac9b4 100644 --- a/src/main/nvm/world.lisp +++ b/src/main/nvm/world.lisp @@ -19,12 +19,10 @@ (defun clear-ticks () (setf *ticks* nil)) -(defun clear-all () +(defcommand clear-all () "CLEAR-ALL => RESULT -ARGUMENTS AND VALUES: - - RESULT: undefined + RESULT: :undefined DESCRIPTION: @@ -35,12 +33,10 @@ DESCRIPTION: (clear-patches) (clear-ticks)) -(defun display () +(defcommand display () "DISPLAY => RESULT -ARGUMENTS AND VALUES: - - RESULT: undefined + RESULT: :undefined DESCRIPTION: @@ -50,12 +46,10 @@ DESCRIPTION: See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#display" nil) -(defun reset-ticks () +(defcommand reset-ticks () "RESET-TICKS => RESULT -ARGUMENTS AND VALUES: - - RESULT: undefined + RESULT: :undefined DESCRIPTION: @@ -64,12 +58,10 @@ DESCRIPTION: See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#reset-ticks" (setf *ticks* 0d0)) -(defun tick () +(defcommand tick () "RESET-TICKS => RESULT -ARGUMENTS AND VALUES: - - RESULT: undefined + RESULT: :undefined DESCRIPTION: -- 2.25.1 From 687ec5dde86dc5e9a46f1441051d2b1da13c4478 Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Sat, 4 Jun 2016 11:34:55 -0500 Subject: [PATCH 15/16] Model export as lisp - Wolf sheep --- bin/buildlinuxexec.sh | 3 +- src/main/extensions/cli/cli.lisp | 2 +- src/main/main.lisp | 58 ++++++++++++++++++++++++++++++++ src/main/package.lisp | 3 +- 4 files changed, 63 insertions(+), 3 deletions(-) diff --git a/bin/buildlinuxexec.sh b/bin/buildlinuxexec.sh index 37c6d8a..d13d6fe 100755 --- a/bin/buildlinuxexec.sh +++ b/bin/buildlinuxexec.sh @@ -31,8 +31,9 @@ mkdir -p tmp/deps/ SBCL_HOME="" tmp/sbcl/bin/sbcl --core tmp/sbcl/lib/sbcl/sbcl.core \ --eval "(require 'asdf)" \ - --eval "(asdf:initialize-source-registry '(:source-registry (:tree \"${PWD}/tmp/deps\") (:directory \"${PWD}/src/main\") :IGNORE-INHERITED-CONFIGURATION))" \ + --eval "(asdf:initialize-source-registry '(:source-registry (:tree \"${PWD}/tmp/deps\") (:tree \"${PWD}/src/main\") :IGNORE-INHERITED-CONFIGURATION))" \ --eval "(asdf:load-system :clnl)" \ + --eval "(asdf:load-system :clnl-extension-cli)" \ --eval "(asdf:clear-output-translations)" \ --eval '(sb-ext:save-lisp-and-die "clnl" :executable t :toplevel (function clnl:run))' diff --git a/src/main/extensions/cli/cli.lisp b/src/main/extensions/cli/cli.lisp index 6d24da7..3ca0983 100644 --- a/src/main/extensions/cli/cli.lisp +++ b/src/main/extensions/cli/cli.lisp @@ -31,5 +31,5 @@ DESCRIPTION: (:|:LOAD| (concatenate 'string ":load loads up a model into the current clnl instance." - " Try :load \"resources/models/Wolf Sheep Predation.nlogo\"")) + " Try :load \"Wolf Sheep Predation.nlogo\"")) (t (format nil "Don't have help for ~S" token)))))) diff --git a/src/main/main.lisp b/src/main/main.lisp index a226642..b0d82eb 100644 --- a/src/main/main.lisp +++ b/src/main/main.lisp @@ -129,6 +129,64 @@ DESCRIPTION: prim)) prims))) :undefined))) +(defun nlogo->lisp (str pkg-symb boot-fn &key (seed 15) initialize-interface netlogo-callback-fn) + (let* + ((model (clnl-model:read-from-nlogo str)) + (shadow-symbs + (remove nil + (mapcar + (lambda (proc-symb) + (multiple-value-bind (found external) (find-symbol (symbol-name proc-symb) :cl) + (when (and found (eql :external external)) proc-symb))) + (mapcar #'car + (clnl-code-parser:procedures + (clnl-code-parser:parse + (clnl-lexer:lex (clnl-model:code model)) + (clnl-model:widget-globals model)))))))) + (eval + `(progn + (defpackage ,pkg-symb (:use :common-lisp) (:shadow ,@shadow-symbs)) + (,(intern "IN-PACKAGE" :cl) ,pkg-symb) ; intern because of style check + (cons + `(defpackage ,,pkg-symb (:use :common-lisp) (:shadow ,,@shadow-symbs)) + (let + ((clnl:*model-package* (find-package ,pkg-symb))) + (clnl:model->multi-form-lisp + ,model + (intern (symbol-name ',boot-fn) ,pkg-symb) + :seed ,seed + :initialize-interface ,initialize-interface + :netlogo-callback-fn ,netlogo-callback-fn))))))) + +(setf (documentation 'nlogo->lisp 'function) + "NLOGO->LISP STR PKG-SYMB BOOT-FN &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK-FN => FORMS + +ARGUMENTS AND VALUES: + + STR: A stream holding an nlogo file + PKG-SYMB: A symbol for the generated package + BOOT-FN: A function name + SEED: An integer, defaults to 15 + INITIALIZE-INTERFACE: A boolean + NETLOGO-CALLBACK-FN: a symbol + FORMS: A list of common lisp form + +DESCRIPTION: + + NLOGO->LISP takes a stream STR and returns a multi form lisp program, + that when executed, sets up the model. See MODEL->MULTI-FORM-LISP for + more information. + + NLOGO->LISP does extra work of setting up the package to be named by + PKG-SYMB in order to correctly shadow common lisp functions. + + It will also change the current package to the one created for the model + named by PKG-SYMB. + +EXAMPLES: + + (with-open-file (str \"Wolf Sheep Predation.nlogo\") (nlogo->lisp str :wolfsheep 'boot)) => (forms)") + (defun model->single-form-lisp (model &key (seed 15) initialize-interface netlogo-callback) (multiple-value-bind (code-ast prims) diff --git a/src/main/package.lisp b/src/main/package.lisp index 8bafc43..73ae492 100644 --- a/src/main/package.lisp +++ b/src/main/package.lisp @@ -1,7 +1,8 @@ (defpackage #:clnl (:use :common-lisp) (:export #:run #:boot #:run-commands #:run-reporter #:*model-package* - #:model->multi-form-lisp #:model->single-form-lisp) + #:model->multi-form-lisp #:model->single-form-lisp + #:nlogo->lisp) (:documentation "Main CLNL package -- 2.25.1 From a66006d87c4364f20442b02a03a7e65a6028407a Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Sun, 5 Jun 2016 08:34:58 -0500 Subject: [PATCH 16/16] 0.1.0 Release - Engine - Wolf sheep works --- README.md | 13 ++++++++----- bin/buildosxexec.sh | 3 ++- bin/buildwindowsexec.sh | 3 ++- bin/generatedocs.sh | 3 ++- bin/release.sh | 8 +++++--- src/main/clnl.asd | 2 +- src/main/interface.lisp | 8 +++++++- wiki | 2 +- 8 files changed, 28 insertions(+), 14 deletions(-) diff --git a/README.md b/README.md index c5b7d58..80ceb76 100644 --- a/README.md +++ b/README.md @@ -4,11 +4,18 @@ This is an experiment at creating an alternate implementation of NetLogo in Comm See the [wiki](https://github.com/frankduncan/clnl/wiki) for more information. +# Using standalone executables + +Find the latest version, [0.1.0](https://github.com/frankduncan/clnl/releases/tag/v0.1.0) on the [releases page](https://github.com/frankduncan/clnl/releases): +* [linux](https://github.com/frankduncan/clnl/releases/download/v0.1.0/clnl) +* [windows](https://github.com/frankduncan/clnl/releases/download/v0.1.0/clnl.exe) +* [mac](https://github.com/frankduncan/clnl/releases/download/v0.1.0/CLNL.dmg) + # Running from source If you'd like to run it from source, you're going to need a few things: -* A copy of the clnl source (either from the [releases page](https://github.com/frankduncan/clnl/releases) or via cloning) +* A copy of the clnl source (either from the [releases page](https://github.com/frankduncan/clnl/releases), version [0.1.0](https://github.com/frankduncan/clnl/releases/download/v0.1.0/clnl_0.1.0.tar.gz) or via cloning) * An implementation of sbcl with threads enabled * The following common lisp libraries (included in [deps/common-lisp](deps/common-lisp) folder) * alexandria @@ -49,7 +56,3 @@ If you'd like to run using your own sbcl instance, you can attach the clnl.asd f (asdf:load-system :clnl) (clnl:run) ``` - -# Using standalone executables - -See the [releases page](https://github.com/frankduncan/clnl/releases) for the most recent release. diff --git a/bin/buildosxexec.sh b/bin/buildosxexec.sh index 963973e..1d9351b 100755 --- a/bin/buildosxexec.sh +++ b/bin/buildosxexec.sh @@ -35,8 +35,9 @@ mkdir -p tmp/deps/ SBCL_HOME="" tmp/sbcl/bin/sbcl --core tmp/sbcl/lib/sbcl/sbcl.core --no-sysinit --no-userinit \ --eval "(require 'asdf)" \ - --eval "(asdf:initialize-source-registry '(:source-registry (:tree \"${PWD}/tmp/deps\") (:directory \"${PWD}/src/main\") :IGNORE-INHERITED-CONFIGURATION))" \ + --eval "(asdf:initialize-source-registry '(:source-registry (:tree \"${PWD}/tmp/deps\") (:tree \"${PWD}/src/main\") :IGNORE-INHERITED-CONFIGURATION))" \ --eval "(asdf:load-system :clnl)" \ + --eval "(asdf:load-system :clnl-extension-cli)" \ --eval "(asdf:clear-output-translations)" \ --eval '(sb-ext:save-lisp-and-die "osxsbcl" :executable t :toplevel (function clnl:run))' \ diff --git a/bin/buildwindowsexec.sh b/bin/buildwindowsexec.sh index 45ffe76..a1d2c28 100755 --- a/bin/buildwindowsexec.sh +++ b/bin/buildwindowsexec.sh @@ -45,8 +45,9 @@ escaped_cur_dir=${cur_dir//\\/\\\\} sbcl --no-sysinit --no-userinit \ --eval "(require 'asdf)" \ - --eval "(asdf:initialize-source-registry '(:source-registry (:tree \"${escaped_cur_dir}\\\\tmp\\\\deps\") (:directory \"${escaped_cur_dir}\\\\src\\\\main\") :IGNORE-INHERITED-CONFIGURATION))" \ + --eval "(asdf:initialize-source-registry '(:source-registry (:tree \"${escaped_cur_dir}\\\\tmp\\\\deps\") (:tree \"${escaped_cur_dir}\\\\src\\\\main\") :IGNORE-INHERITED-CONFIGURATION))" \ --eval "(asdf:load-system :clnl)" \ + --eval "(asdf:load-system :clnl-extension-cli)" \ --eval "(asdf:clear-output-translations)" \ --eval '(sb-ext:save-lisp-and-die "clnl.exe" :executable t :toplevel (function clnl:run))' diff --git a/bin/generatedocs.sh b/bin/generatedocs.sh index ac3cce3..c445a35 100755 --- a/bin/generatedocs.sh +++ b/bin/generatedocs.sh @@ -17,5 +17,6 @@ generatedoc :clnl-cli > wiki/DocsOtherPackages.md generatedoc :clnl-lexer >> wiki/DocsOtherPackages.md generatedoc :clnl-parser >> wiki/DocsOtherPackages.md generatedoc :clnl-transpiler >> wiki/DocsOtherPackages.md -generatedoc :clnl-random >> wiki/DocsOtherPackages.md +generatedoc :clnl-code-parser >> wiki/DocsOtherPackages.md generatedoc :clnl-model >> wiki/DocsOtherPackages.md +generatedoc :clnl-random >> wiki/DocsOtherPackages.md diff --git a/bin/release.sh b/bin/release.sh index 6a78757..d399e6e 100755 --- a/bin/release.sh +++ b/bin/release.sh @@ -2,13 +2,15 @@ # The release process: # * Change version number in clnl.asd -# * Run this script to create the source tarball +# * Change where the README.md points to releases # * Run bin/generatedocs.sh to update wiki -# * Create release on github (that should create the tag) -# * Upload the tar.gz as an extra file # * Create linux release using bin/buildlinuxexech.sh on a linux machine # * Create osx release using bin/buildosxrelease.sh on a mac and upload # * Create windows release using bin/buildwindowsexec.sh on a windows box and upload +# * Make a release commit and push up, most likely a rebase of all the commits to make the previous steps work correctly +# * Run this script to create the source tarball +# * Create release on github (that should create the tag), use v.. as the versioning scheme +# * Upload the tar.gz as an extra file # * Set the tag in wiki milestones, update Running wiki page to point to new release version=$(sbcl --noinform --disable-ldb --lose-on-corruption --end-runtime-options --eval '(format t "~A" (asdf:component-version (asdf:find-system :clnl)))' --eval "(quit)") diff --git a/src/main/clnl.asd b/src/main/clnl.asd index 58bd44b..e70faf0 100644 --- a/src/main/clnl.asd +++ b/src/main/clnl.asd @@ -1,6 +1,6 @@ (asdf:defsystem clnl :name "Experiment" - :version "0.0.0" + :version "0.1.0" :maintainer "Frank Duncan (frank@kank.com)" :author "Frank Duncan (frank@kank.com)" :components ((:file "package") diff --git a/src/main/interface.lisp b/src/main/interface.lisp index 931cede..88dfac5 100644 --- a/src/main/interface.lisp +++ b/src/main/interface.lisp @@ -6,6 +6,8 @@ (defvar *glut-window-opened* nil) (defvar *dimensions* nil) +(defvar *default-shapes* nil) + ; For now, shapes can live in here ; header is ; * name @@ -182,6 +184,10 @@ (defun default-shapes () (with-open-file (str "resources/defaultshapes") (parse-shapes str))) +(eval-when (:load-toplevel) + (when (probe-file "resources/defaultshapes") + (setf *default-shapes* (default-shapes)))) + (defvar *colors* '((140 140 140) ; gray (5) (215 48 39) ; red (15) @@ -290,7 +296,7 @@ (gl:translate -150d0 -150d0 -0.0d0) (mapcar #'element->gl-list (getf shape :elements))) turtle-list)) - (default-shapes)))) + (or *default-shapes* (default-shapes))))) (defun set-patch-list () (setf *patch-list* (gl:gen-lists 1)) diff --git a/wiki b/wiki index 769e5e8..5aa4443 160000 --- a/wiki +++ b/wiki @@ -1 +1 @@ -Subproject commit 769e5e8f99137d05ee9ea7eb5232d923f14b6286 +Subproject commit 5aa4443b92dcdd79e08ba82e64702dcdf239e2fe -- 2.25.1