* mt19937
* nibbles
* trivial-features
+ * style-checker
* rlwrap
# Running
tar zxf ../../deps/tarpit/mt19937-latest.tar.gz &&
tar zxf ../../deps/tarpit/nibbles-v0.12.tar.gz &&
tar zxf ../../deps/tarpit/trivial-features_0.8.tar.gz &&
+ tar zxf ../../deps/tarpit/style-checker_0.1.tar.gz &&
ln -s cl-ppcre-2.0.10/cl-ppcre.asd . &&
ln -s ironclad_0.33.0/ironclad.asd . &&
ln -s mt19937-1.1.1/mt19937.asd . &&
ln -s nibbles-0.12/nibbles.asd . &&
ln -s 3b-cl-opengl-993d627/cl-glut.asd . &&
- ln -s frank/.sbcl/site/3b-cl-opengl-993d627/cl-opengl.asd . &&
+ ln -s 3b-cl-opengl-993d627/cl-opengl.asd . &&
ln -s alexandria-b1c6ee0/alexandria.asd . &&
ln -s babel_0.5.0/babel-streams.asd . &&
ln -s babel_0.5.0/babel.asd . &&
ln -s cffi_0.15.0/cffi-libffi.asd . &&
ln -s cffi_0.15.0/cffi-grovel.asd . &&
ln -s cffi_0.15.0/cffi-uffi-compat.asd . &&
- ln -s trivial-features_0.8/trivial-features.asd .
+ ln -s trivial-features_0.8/trivial-features.asd . &&
+ ln -s style-checker_0.1/style-checker.asd .
)
--eval "(asdf:load-system :ironclad)" \
--eval "(asdf:load-system :cl-opengl)" \
--eval "(asdf:load-system :cl-glut)" \
+ --eval "(asdf:load-system :style-checker)" \
--eval "(asdf:clear-output-translations)" \
--eval '(sb-ext:save-lisp-and-die "deps/travissbcl" :executable t)' \
chmod +x deps/travissbcl
-rm -rf tmp
+# rm -rf tmp
(setf asdf:*central-registry* (list #p"deps/"))
(asdf:load-system :clnl.internal)
(asdf:load-system :clnl-test.internal)
-(sb-ext:quit :unix-status (if (clnl-test:run-all-tests) 0 1))
+
+(format t "~%~c[1;33mRunning Tests~c[0m~%" #\Esc #\Esc)
+(when (not (clnl-test:run-all-tests))
+ (format t "~c[1;31mFailed tests!~c[0m~%" #\Esc #\Esc)
+ (sb-ext:exit :code 1))
+
+(format t "~%~c[1;33mChecking Style~c[0m~%" #\Esc #\Esc)
+(when (not (syntax-checker:pretty-print-check-directory "src"))
+ (format t "~c[1;31mFailed style check!~c[0m~%" #\Esc #\Esc)
+ (sb-ext:exit :code 1))
+
+(format t "~c[1;32mSuccess!~c[0m~%" #\Esc #\Esc)
+(sb-ext:exit :code 0)
-650da2544c51bb2842aca26d8d3c584de4aefa8e
\ No newline at end of file
+5ba26ad20f3cda2796a44d201fba629edd567e4c
\ No newline at end of file
(defvar *world-dims* '(:xmin -5 :xmax 5 :ymin -5 :ymax 5))
(defvar *turtle-list* nil)
-(car clnl-nvm::*turtles*)
; It may be useful to keep windows around
(defvar *glut-window-opened* nil)
(mapcar
(lambda (turtle)
(let
- ((color (nl-color->rgb (clnl-nvm::turtle-color turtle))))
+ ((color (nl-color->rgb (clnl-nvm:turtle-color turtle))))
(gl:color (car color) (cadr color) (caddr color)))
(gl:with-pushed-matrix
- (gl:translate (* (clnl-nvm::turtle-xcor turtle) *patch-size*) (* (clnl-nvm::turtle-ycor turtle) *patch-size*) 0)
- (gl:rotate (clnl-nvm::turtle-heading turtle) 0 0 -1)
+ (gl:translate (* (clnl-nvm:turtle-xcor turtle) *patch-size*) (* (clnl-nvm:turtle-ycor turtle) *patch-size*) 0)
+ (gl:rotate (clnl-nvm:turtle-heading turtle) 0 0 -1)
(gl:call-list *turtle-list*)))
- clnl-nvm::*turtles*)
+ (clnl-nvm:turtles))
(gl:flush))
(defun display ()
(let
((fbo (first (gl:gen-framebuffers 1)))
(render-buf (first (gl:gen-renderbuffers 1)))
- (width 143) ; Hard coded for now, yay v1 (if you see this comment in a year, please cry for me)
- (height 143)
;(width (floor (* *patch-size* (1+ (- (getf *world-dims* :xmax) (getf *world-dims* :xmin))))))
;(height (floor (* *patch-size* (1+ (- (getf *world-dims* :ymax) (getf *world-dims* :ymin))))))
- )
+ (width 143) ; Hard coded for now, yay v1 (if you see this comment in a year, please cry for me)
+ (height 143))
(gl:bind-framebuffer :framebuffer fbo)
(gl:bind-renderbuffer :renderbuffer render-buf)
(gl:renderbuffer-storage :renderbuffer :rgba8 width height)
(defmacro deflex (state match &optional func)
(let
((scanner (gensym)))
- `(let
- ((,scanner (when (stringp ,match) (cl-ppcre:create-scanner ,match))))
- (pushnew
- (list
- (lambda (state text)
- (and
- (eql ,state state)
- (or
- (and (symbolp text) (eql text ,match))
- (and ,scanner
- (stringp text)
- (multiple-value-bind (start end) (cl-ppcre:scan ,scanner text)
- (and start end (= 0 start) (/= 0 end)))))))
- (lambda (text) (second (multiple-value-list (cl-ppcre:scan ,scanner text))))
- ,(or func #'as-symbol))
- *lexes*))))
+ `(let
+ ((,scanner (when (stringp ,match) (cl-ppcre:create-scanner ,match))))
+ (pushnew
+ (list
+ (lambda (state text)
+ (and
+ (eql ,state state)
+ (or
+ (and (symbolp text) (eql text ,match))
+ (and
+ ,scanner
+ (stringp text)
+ (multiple-value-bind (start end) (cl-ppcre:scan ,scanner text)
+ (and start end (= 0 start) (/= 0 end)))))))
+ (lambda (text) (second (multiple-value-list (cl-ppcre:scan ,scanner text))))
+ ,(or func #'as-symbol))
+ *lexes*))))
(defun lex (text)
(if (string= "" text)
- (let
- ((lex (find-if (lambda (f) (funcall f *state* :eof)) *lexes* :from-end t :key #'car)))
- (when lex (list (funcall (third lex) :eof))))
- (let
- ((lex (find-if (lambda (f) (funcall f *state* text)) *lexes* :from-end t :key #'car)))
- (when (not lex) (error "Can't lex this: ~S" text))
- (let
- ((val (funcall (third lex) (subseq text 0 (funcall (cadr lex) text)))))
- (if val
- (cons val (lex (subseq text (funcall (cadr lex) text))))
- (lex (subseq text (funcall (cadr lex) text))))))))
+ (let
+ ((lex (find-if (lambda (f) (funcall f *state* :eof)) *lexes* :from-end t :key #'car)))
+ (when lex (list (funcall (third lex) :eof))))
+ (let
+ ((lex (find-if (lambda (f) (funcall f *state* text)) *lexes* :from-end t :key #'car)))
+ (when (not lex) (error "Can't lex this: ~S" text))
+ (let
+ ((val (funcall (third lex) (subseq text 0 (funcall (cadr lex) text)))))
+ (if val
+ (cons val (lex (subseq text (funcall (cadr lex) text))))
+ (lex (subseq text (funcall (cadr lex) text))))))))
(defun set-state (new-state)
(setf *state* new-state))
(defun r (str)
(let*
- ((lexed-ast (let ((ast (clnl-lexer:lex str))) (format t "Via lexing, AST for~%~S~% became~%~S~%~%" str ast) ast))
- (parsed-ast (let ((ast (clnl-parser:parse lexed-ast))) (format t "Via parsing, AST for~%~S~% became~%~S~%~%" lexed-ast ast) ast))
- (transpiled-ast (let ((ast (clnl-transpiler:transpile-commands parsed-ast))) (format t "Via transpiling, AST for~%~S~% became~%~S~%" parsed-ast ast) ast)))
+ ((lexed-ast (let ((ast (clnl-lexer:lex str)))
+ (format t "Via lexing, AST for~%~S~% became~%~S~%~%" str ast) ast))
+ (parsed-ast (let ((ast (clnl-parser:parse lexed-ast)))
+ (format t "Via parsing, AST for~%~S~% became~%~S~%~%" lexed-ast ast) ast))
+ (transpiled-ast (let ((ast (clnl-transpiler:transpile-commands parsed-ast)))
+ (format t "Via transpiling, AST for~%~S~% became~%~S~%" parsed-ast ast) ast)))
(eval transpiled-ast)))
(defun p (result) result)
(defun run ()
- (loop for str = (progn (format t "> ") (force-output) (read-line))
- while str
- do (p (e (r str))))
+ (loop
+ :for str := (progn (format t "> ") (force-output) (read-line))
+ :while str
+ :do (p (e (r str))))
(sb-ext:exit))
(defun boot ()
(clnl-nvm:create-world))
(defun run-commands (cmds)
- (eval (clnl-transpiler:transpile-commands (clnl-parser:parse (clnl-lexer:lex cmds)))))
+ (eval (clnl-transpiler:transpile-commands (clnl-parser:parse (clnl-lexer:lex cmds)))))
(defun run-reporter (reporter)
(eval (clnl-transpiler:transpile-reporter (car (clnl-parser:parse (clnl-lexer:lex reporter))))))
(nconc
*turtles*
(list
- (make-turtle :who *current-id*
- :color (coerce (+ 5 (* 10 (clnl-random:next-int 14))) 'double-float)
- :heading (coerce (clnl-random:next-int 360) 'double-float)
- :xcor 0d0
- :ycor 0d0))))
+ (make-turtle
+ :who *current-id*
+ :color (coerce (+ 5 (* 10 (clnl-random:next-int 14))) 'double-float)
+ :heading (coerce (clnl-random:next-int 360) 'double-float)
+ :xcor 0d0
+ :ycor 0d0))))
(incf *current-id*))
(defun turtles ()
-"Reports the agentset consisting of all turtles.
+ "Reports the agentset consisting of all turtles.
See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles"
*turtles*)
(defun ask (agent-set fn)
-"The specified agent or agentset runs the given commands.
+ "The specified agent or agentset runs the given commands.
See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ask"
(let
((iter (shufflerator agent-set)))
- (loop for agent = (funcall iter)
- while agent
- do (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
+ (loop
+ :for agent := (funcall iter)
+ :while agent
+ :do (let ((*myself* *self*) (*self* agent)) (funcall fn)))))
(defun shufflerator (agent-set)
(let
(t (let ((result agent)) (fetch) result)))))))
(defun random-float (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 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 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.
(clnl-random:next-double n))
(defun forward (n)
-"The turtle moves forward by number steps, one step at a time. (If number is negative, the turtle moves backward.)
+ "The turtle moves forward by number steps, one step at a time. (If number is
+negative, the turtle moves backward.)
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*))
(setf (turtle-ycor *self*) (+ (turtle-ycor *self*) (* n (cos (* pi (/ (turtle-heading *self*) 180)))))))
(defun create-turtles (n)
-"Creates number new turtles at the origin. New turtles have random integer
+ "Creates number new turtles at the origin. New turtles have random integer
headings and the color is randomly selected from the 14 primary colors.
If commands are supplied, the new turtles immediately run them.
See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles"
- (loop for i from 1 to n do (create-turtle)))
+ (loop :for i :from 1 :to n :do (create-turtle)))
(defun create-world ()
(setf *turtles* nil)
; 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)))
- (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-"))))) ; Someday we'll have d<posint>, but this is not that day!
+ (format nil "~A" int)
+ (let
+ ((output (format nil "~D" n)))
+ ; Someday we'll have d<posint>, but this is not that day!
+ (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-")))))
+
(defmethod dump-object ((o string)) o)
(defun export-world ()
(format nil "~S" (clnl-random:export))
""
(format nil "~S" "GLOBALS")
- "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\",\"nextIndex\",\"directed-links\",\"ticks\","
+ (format nil "~A~A"
+ "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\","
+ "\"nextIndex\",\"directed-links\",\"ticks\",")
(format nil "\"-1\",\"1\",\"-1\",\"1\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"-1\"" *current-id*)
""
(format nil "~S" "TURTLES")
- "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\",\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\""
+ (format nil "~A~A"
+ "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\","
+ "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\"")
(format nil "~{~A~%~}"
(mapcar
(lambda (turtle)
(format nil
- "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"\"\"default\"\"\",\"\"\"\"\"\",\"9.9\",\"{all-turtles}\",\"false\",\"1\",\"1\",\"\"\"up\"\"\""
+ "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",~A"
(turtle-who turtle)
(dump-object (turtle-color turtle))
(dump-object (turtle-heading turtle))
(dump-object (turtle-xcor turtle))
(dump-object (turtle-ycor turtle))
- ))
+ "\"\"\"default\"\"\",\"\"\"\"\"\",\"9.9\",\"{all-turtles}\",\"false\",\"1\",\"1\",\"\"\"up\"\"\""))
*turtles*))
(format nil "~S" "PATCHES")
"\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\""
""
(format nil "~S" "LINKS")
"\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\""
- ""
- )))
+ "")))
(defpackage #:clnl-nvm
(:use :common-lisp)
- (:export :export-world :create-world :dump-object
+ (:export :export-world :create-world :dump-object :turtle-color :turtle-xcor :turtle-ycor :turtle-heading
; API as used by transpiled NetLogo programs
#:ask
#:create-turtles
(prim-name prim)
(mapcar
#'help-arg
- (prim-args prim)
+ (prim-args prim)
(butlast parsed-remainder (- (length parsed-remainder) num-args))))
(nthcdr num-args parsed-remainder))))
(t (error "Couldn't parse ~S" lexed-ast))))
(case arg-type
(:command-block
(if (not (and (consp arg) (eql 'block (car arg))))
- (error "Required a block, but found a ~A" arg)
- (cons :command-block (cdr arg))))
+ (error "Required a block, but found a ~A" arg)
+ (cons :command-block (cdr arg))))
(t arg)))
(defun parse-block (tokens)
; This is a wrapper around the very nice mersenne twister mt19937 to match
; NetLogo's implementation that tries to match how java.util.Random works
-
+
(defun set-seed (n)
- (setf mt19937:*random-state* (mt19937::make-random-object :state (mt19937:init-random-state n))))
+ (setf mt19937:*random-state* (funcall
+ (symbol-function (intern "MAKE-RANDOM-OBJECT" :mt19937))
+ :state (mt19937:init-random-state n))))
(defun next-int (n)
(if
(let
((y (mt19937:random-chunk mt19937:*random-state*))
(z (mt19937:random-chunk mt19937:*random-state*)))
- (*
- (/
- (+ (ash (ash y -6) 27) (ash z -5))
- (coerce (ash 1 53) 'double-float))
- n)))
+ (*
+ (/
+ (+ (ash (ash y -6) 27) (ash z -5))
+ (coerce (ash 1 53) 'double-float))
+ n)))
; Oh, export world, you WILL be mine
(defun export ()
(map
'list
(lambda (x) (if (logbitp (1- 32) x) (dpb x (byte 32 0) -1) x))
- (mt19937::random-state-state mt19937:*random-state*))))
+ (funcall (symbol-function (intern "RANDOM-STATE-STATE" :mt19937)) mt19937:*random-state*))))
(format nil "0 ~A ~A ~A 0.0 false ~{~A~^ ~}"
(first state) (second state) (third state)
(nthcdr 3 state))))
(defun run-tests (tests)
(let
((final-result t))
- (loop for test in tests
- for result = (run-and-print-test test)
- do (setf final-result (and final-result result)))
+ (loop
+ :for test :in tests
+ :for result := (run-and-print-test test)
+ :do (setf final-result (and final-result result)))
final-result))
(defun run-all-tests ()
- (format t "~%~c[1;33mHere we goooooooo~c[0m~%" #\Esc #\Esc)
(run-tests (reverse *tests*)))
-
+
(defun run-tests-matching (match)
- (run-tests (remove-if-not (lambda (test-name) (cl-ppcre:scan (format nil "^~A$" match) test-name)) *tests* :key #'car)))
+ (run-tests
+ (remove-if-not (lambda (test-name) (cl-ppcre:scan (format nil "^~A$" match) test-name)) *tests* :key #'car)))
(defun find-test (name)
(or
(defun checksum= (expected got)
(if (stringp expected)
- (string= got expected)
- (find got expected :test #'string=)))
+ (string= got expected)
+ (find got expected :test #'string=)))
; To be used only with the simplest of tests, just a list of commands and a checksum of the
; world after they've been run.
(defun save-view-to-ppm ()
(let
((height 143) (width 143)) ; hardcoded in interface, hardcoded here, cry for me
- (with-open-file (str "cl.ppm" :direction :output :if-exists :supersede :if-does-not-exist :create :element-type '(unsigned-byte 8))
+ (with-open-file (str "cl.ppm"
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create
+ :element-type '(unsigned-byte 8))
(write-sequence (map 'vector #'char-code (format nil "P6~%")) str)
(write-sequence (map 'vector #'char-code (format nil "143 143~%")) str)
(write-sequence (map 'vector #'char-code (format nil "255~%")) str)
(write-byte (aref image-data (+ 2 (* 4 (+ (* (- (1- height) i) width) j)))) str)))))))
(defun run ()
- (loop for str = (progn (format t "> ") (force-output) (read-line))
- while str
- do (progn (asdf:load-system :clnl-test) (run-tests-matching str))))
+ (loop
+ :for str := (progn (format t "> ") (force-output) (read-line))
+ :while str
+ :do (progn (asdf:load-system :clnl-test) (run-tests-matching str))))
(in-package #:clnl-test)
-(defsimplecommandtest "Nothing" "" "E1DE30F072D785E0D0B59F28B0F7853E3D3E0D8B")
-(defsimplecommandtest "Simple crt" "crt 1" "2F08B31AC06C9D5339E6B3E953C2B4B71FDB9CDE")
-(defsimplecommandtest "Simple crt 2" "crt 5" "9FE588C2749CD9CE66CB0EA451EFB80476E881FB")
-(defsimplecommandtest "Simple crt and fd" "crt 5 ask turtles [ fd 1 ]" "BEB43404EDC7852985A9A7FC312481785FE553A0")
-(defsimplecommandtest "Simple crt and fd random" "crt 5 ask turtles [ fd random-float 1 ]" "F7AC3B3492CDFD01D1FB5BD69FAAA67E06D3A870")
-;(defsimplecommandtest "Simple crt and fd random 2" "crt 30 ask turtles [ fd random-float 1 ]" "F7AC3B3492CDFD01D1FB5BD69FAAA67E06D3A870") ; we start getting floating errors, cool!
-
-(defsimplereportertest "Random 1" "random-float 5" "4.244088516651127" "17D1BF7FF7BF2C7F3F5F7DD7CF67CFF2772CFFFC")
+(defsimplecommandtest "Nothing" ""
+ "E1DE30F072D785E0D0B59F28B0F7853E3D3E0D8B")
+
+(defsimplecommandtest "Simple crt" "crt 1"
+ "2F08B31AC06C9D5339E6B3E953C2B4B71FDB9CDE")
+
+(defsimplecommandtest "Simple crt 2" "crt 5"
+ "9FE588C2749CD9CE66CB0EA451EFB80476E881FB")
+
+(defsimplecommandtest "Simple crt and fd" "crt 5 ask turtles [ fd 1 ]"
+ "BEB43404EDC7852985A9A7FC312481785FE553A0")
+
+(defsimplecommandtest "Simple crt and fd random" "crt 5 ask turtles [ fd random-float 1 ]"
+ "F7AC3B3492CDFD01D1FB5BD69FAAA67E06D3A870")
+;(defsimplecommandtest "Simple crt and fd random 2" "crt 30 ask turtles [ fd random-float 1 ]"
+; "F7AC3B3492CDFD01D1FB5BD69FAAA67E06D3A870") ; we start getting floating errors, cool!
+
+(defsimplereportertest "Random 1" "random-float 5" "4.244088516651127"
+ "17D1BF7FF7BF2C7F3F5F7DD7CF67CFF2772CFFFC")
(in-package #:clnl-test)
-(defviewtest "Basic 1" "crt 1" "FE38C1C9873FD97451A41EB89CE47E60DAB0DD03")
-(defviewtest "Basic 2" "crt 10 ask turtles [ fd 1 ]" '("99673570760F0A2E3B49B858AFC8CCDAE16C78D5" "9A7CB6E13203687AB09CBA4CEFF7912534D69542"))
+(defviewtest "Basic 1" "crt 1"
+ "FE38C1C9873FD97451A41EB89CE47E60DAB0DD03")
+
+(defviewtest "Basic 2" "crt 10 ask turtles [ fd 1 ]"
+ '("99673570760F0A2E3B49B858AFC8CCDAE16C78D5" "9A7CB6E13203687AB09CBA4CEFF7912534D69542"))
projects / clnl / commitdiff