From 471de83db1aee70065808cbc061867e3320bf4b7 Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Mon, 13 Jul 2015 00:24:08 -0500 Subject: [PATCH] Add CL style Former-commit-id: ee78f426755cd6cad50173d991d67f50d00c3175 --- README.md | 1 + bin/buildtravisexec.sh | 9 ++-- bin/travis.lisp | 14 +++++- deps/tarpit/style-checker_0.1.tar.gz | Bin 0 -> 2944 bytes deps/travissbcl.REMOVED.git-id | 2 +- src/main/interface.lisp | 14 +++--- src/main/lex.lisp | 55 ++++++++++++------------ src/main/main.lisp | 18 +++++--- src/main/nvm.lisp | 61 ++++++++++++++++----------- src/main/package.lisp | 2 +- src/main/parse.lisp | 6 +-- src/main/random.lisp | 18 ++++---- src/test/main.lisp | 30 +++++++------ src/test/simpletests.lisp | 27 ++++++++---- src/test/viewtests.lisp | 7 ++- 15 files changed, 158 insertions(+), 106 deletions(-) create mode 100644 deps/tarpit/style-checker_0.1.tar.gz diff --git a/README.md b/README.md index 2fa28a6..4e5dcd5 100644 --- a/README.md +++ b/README.md @@ -18,6 +18,7 @@ If you'd like to build it, you're going to need a few things: * mt19937 * nibbles * trivial-features + * style-checker * rlwrap # Running diff --git a/bin/buildtravisexec.sh b/bin/buildtravisexec.sh index a198de2..5715bf2 100755 --- a/bin/buildtravisexec.sh +++ b/bin/buildtravisexec.sh @@ -20,12 +20,13 @@ mkdir -p tmp/deps/ 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 . && @@ -34,7 +35,8 @@ mkdir -p tmp/deps/ 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 . ) @@ -46,9 +48,10 @@ SBCL_HOME="" tmp/sbcl/bin/sbcl --core tmp/sbcl/lib/sbcl/sbcl.core \ --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 diff --git a/bin/travis.lisp b/bin/travis.lisp index 42ff833..0430056 100644 --- a/bin/travis.lisp +++ b/bin/travis.lisp @@ -3,4 +3,16 @@ (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) diff --git a/deps/tarpit/style-checker_0.1.tar.gz b/deps/tarpit/style-checker_0.1.tar.gz new file mode 100644 index 0000000000000000000000000000000000000000..568ed83e095cff22db1ae347d2235c2635986514 GIT binary patch literal 2944 zcmV-`3xD(v8?}EI9i=vTr4jyPA|_fZgqBkd3nSxo}ZO2>#N>vvBG_^kY}1{P3e6uG~$0^;L(&-i^1%484bxu$QasEKtdtJ5V5H<%fM zuacQv!CAUyJHhX>G$*9RetVrJ1*sr~pgA*oET_oeT0j3$)Cq$%dB-6ww+aP@Kuep_ zQxS`sge%6>^qPsRXzMt~gSEgq#_*khp$h#R7nT_nzm}o9O)R7+n;k z1<7Cua09-pNp=+9W^!-FR(Oc89s#4|Y!iIqOx`s|D?#)0uBnxpd>Lj|h*Dq?H_!$P zlN9>5?t$JP?n9o*I5pl9rdy>-^-}pmA#=>ut^7Vrc2R?x@^iM%(`{2-82>JX*UC-0 zyV)qLp0*Dq3rP&+Jcz*SHVE^yV0Uqn7>QFd57>@a5JeOM@PiHP5vCDWczDUVo(63R zxeF2~Bgo@|zhX3*A}2@aX?wQuhol!CDSR|C%TuK}uoy_i9}MCoX_`6Y3wJ!uquI=j z_!?UA!c;^taiA68t%Eq(!Q3KFnCotf8|KF%hNO5L{?uV@wW<9>F<^JtKXdYE&vq8>TT-CvEdeDu;egDg`11U=RWr{#sC4$oI$`R_jPx zI-8ZAyAxR9q&6#a)el);JB&yra}n(k)BPPcm{WAQJkKG8^L-#*O2TGFBg;Izb@U4j zbkVgg!^Dy@ZVFaZ8f17V!@w}4#bKoCC-GKt_VAVx7*^$20CjAp)LBcoBuU&N41|Eg zyEj-P_S?A<@b9LZ2D~aqXg0JuGxkdH2$EsqWm%YWAOC^fv*XPGjS-l#U9my&GPB98 zkTaX;g6(w_SlK1Nmt_uf;W%YJb4fw`W1@}zN(-Y~^h+gQHKWRggbPHJBW0S5o=lG= zyUp>nTxu0jYbuq|;F&tqVu~c=k!87e9V^l*Yan&iwMJM=+#N)k>2e}-->{{Aooi_8 z(1=xVTCO^Lkk-d(S14Z@_amq$>UlksOglG(;aKt7s^txHoKhh2C`zL6sG7HvJ9{+4 zvcCrJM3)R)g^thDHN3mAT=-Og&^o{*^Kbc{y?7Z0dFgC#>o$Xz4}%0RZK zRHmL$&es9uZiCx;1@N+20;u)gPAOOEYALi!t6c>REgNN@qY`bb!&Fj}OJ$KtXss+I zqlwE=L5*i9aa~=@~x;eiDbdR8u!*s4jY_OKY@WO54e&X20bi!3Amo{|?&pj&hW;!$9h*`@aDl3*F7O9=`F^--o}v|Jl)=qza1)9dlRT63$%?f49w5d%SKp>qJ~f&=-|$ zLNE<&%xQO;q0H=1WPX&IFtcYEW!zN_M6JUWJDoT5#--eQT75%?w$-ySfZHCY%}GOy zvL$nVOUm`x_v(}|B1Mz5besWR=*^fL%Kk>Jm_Sl4h{glTcL=skKk+I&dR(DJ|KXp? zkpFUOe%f-9Ly@YjNW(=9e@c%ac| z;e+^T;moQ+Xx^9ItmPiT+1}qCM52Fh+(**v`M;2Hi{--yw=sQYc26e9RVlk%)f@S_ zo$>4Y={~ZJ{dO;LibP$gsx1_mzd_J=#6NhB2(8sS%&Cr>8;8tvijoSmwa56~RygyD zLSwaYPu}QUqDmq+Y@H4fnTn*UHJrDJrdOR6ch1JyYas^%U=Q(*`F zN=IoF(*zx@JHIF1NP%=%PN(0_kW(w`R41|IYV)5K_~U$Gl=K}u(Wa~I2)gbpRpYIw zwGx1~9x9zxr`LnBjFEA@2l}Jau!H)sZt!tso!?JVeD4sAdjO|Js327 z3&>}M&{K&Vu+lu~oVC}WRRP{LZNF^~F>amdFXftzte(%IwzAIX_4l=s_&e6xG`DGd$?fpZp8H63O*VvL-o_MQ((@JDaLA!!R@Cm1(4+JrKaq! zM4H##fxc#O+D_kI+dofd9RZ(Eq*cqryo07ZMpQMAn^6(gtdLZQ3{R7WFFq5WCt zyOW4=C>c+g%`yIoIJj6c*Q+i1ssdA!slfYDDKk{(f6!)1m)Q1$19fO*G08^{4BR(E zRMY}7rWN1sIwN*AJQwJ-4yJCbo8KJtIcIrgM9Ky@P1NIyl^Wfjxw=+xg}9BK;;G ztB?k3(B_vjSiBIcD3gLgOUP;TaJSw`eGX6-~TO_XIH28`@iM# zbak{`U0y9OrtklL3221cmwafBj3i=b`af{I4!;{GVT*Eh+vl zuFh9e{QnZ5KNjo%{ul8=2YCn@x+(DWhp!k_yA!f6)rG+ef9&32in|FWm|%hlCYWG? q2_~3ef(a&=V1fxIm|%hlCYWG?2_~3ef(a)03h-|OSZZbfPyhfJ6S+YE literal 0 HcmV?d00001 diff --git a/deps/travissbcl.REMOVED.git-id b/deps/travissbcl.REMOVED.git-id index 5164fa3..c65f7d3 100644 --- a/deps/travissbcl.REMOVED.git-id +++ b/deps/travissbcl.REMOVED.git-id @@ -1 +1 @@ -650da2544c51bb2842aca26d8d3c584de4aefa8e \ No newline at end of file +5ba26ad20f3cda2796a44d201fba629edd567e4c \ No newline at end of file diff --git a/src/main/interface.lisp b/src/main/interface.lisp index ad09762..387679e 100644 --- a/src/main/interface.lisp +++ b/src/main/interface.lisp @@ -4,7 +4,6 @@ (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) @@ -44,13 +43,13 @@ (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 () @@ -117,11 +116,10 @@ (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) diff --git a/src/main/lex.lisp b/src/main/lex.lisp index 780aec2..b0ef2f1 100644 --- a/src/main/lex.lisp +++ b/src/main/lex.lisp @@ -13,36 +13,37 @@ (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)) diff --git a/src/main/main.lisp b/src/main/main.lisp index 594e787..8304d0f 100644 --- a/src/main/main.lisp +++ b/src/main/main.lisp @@ -4,17 +4,21 @@ (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 () @@ -22,7 +26,7 @@ (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)))))) diff --git a/src/main/nvm.lisp b/src/main/nvm.lisp index 2c2cdbd..2b30edf 100644 --- a/src/main/nvm.lisp +++ b/src/main/nvm.lisp @@ -21,28 +21,30 @@ See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#show" (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 @@ -64,9 +66,11 @@ See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#ask" (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. @@ -74,7 +78,8 @@ See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-float" (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*)) @@ -82,13 +87,13 @@ See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#forward" (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) @@ -96,13 +101,16 @@ See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-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))) - (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-"))))) ; Someday we'll have d, but this is not that day! + (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)) o) (defun export-world () @@ -112,22 +120,26 @@ See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles" (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\"" @@ -143,5 +155,4 @@ See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles" "" (format nil "~S" "LINKS") "\"end1\",\"end2\",\"color\",\"label\",\"label-color\",\"hidden?\",\"breed\",\"thickness\",\"shape\",\"tie-mode\"" - "" - ))) + ""))) diff --git a/src/main/package.lisp b/src/main/package.lisp index 133d9b4..e812ac0 100644 --- a/src/main/package.lisp +++ b/src/main/package.lisp @@ -16,7 +16,7 @@ (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 diff --git a/src/main/parse.lisp b/src/main/parse.lisp index 10e2f08..70e141d 100644 --- a/src/main/parse.lisp +++ b/src/main/parse.lisp @@ -45,7 +45,7 @@ (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)))) @@ -54,8 +54,8 @@ (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) diff --git a/src/main/random.lisp b/src/main/random.lisp index 6f500a9..d8a38c0 100644 --- a/src/main/random.lisp +++ b/src/main/random.lisp @@ -2,9 +2,11 @@ ; 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 @@ -16,11 +18,11 @@ (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 () @@ -29,7 +31,7 @@ (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)))) diff --git a/src/test/main.lisp b/src/test/main.lisp index 19c9667..36952eb 100644 --- a/src/test/main.lisp +++ b/src/test/main.lisp @@ -13,17 +13,18 @@ (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 @@ -43,8 +44,8 @@ (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. @@ -115,7 +116,11 @@ (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) @@ -128,6 +133,7 @@ (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)))) diff --git a/src/test/simpletests.lisp b/src/test/simpletests.lisp index 8427ef0..68b460d 100644 --- a/src/test/simpletests.lisp +++ b/src/test/simpletests.lisp @@ -1,10 +1,21 @@ (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") diff --git a/src/test/viewtests.lisp b/src/test/viewtests.lisp index bd8c663..0eca5ab 100644 --- a/src/test/viewtests.lisp +++ b/src/test/viewtests.lisp @@ -1,4 +1,7 @@ (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")) -- 2.25.1