From: Frank Duncan Date: Sat, 2 Apr 2016 14:09:32 +0000 (-0500) Subject: Parse widgets v1 - view X-Git-Tag: v0.1.0~64 X-Git-Url: https://code.consxy.com/gitweb/?a=commitdiff_plain;h=2d8a7c97e20e7b68b11ee2d70d4a59da84b0d862;p=clnl Parse widgets v1 - view --- diff --git a/src/main/model.lisp b/src/main/model.lisp index 5af89f2..ee776c7 100644 --- a/src/main/model.lisp +++ b/src/main/model.lisp @@ -41,7 +41,7 @@ DESCRIPTION: (read-sections)))) (make-model :code (nth 0 sections) - :interface (nth 1 sections) + :interface (parse-interface (nth 1 sections)) :info (nth 2 sections) :turtle-shapes (nth 3 sections) :version (nth 4 sections) @@ -52,3 +52,99 @@ DESCRIPTION: :link-shapes (nth 9 sections) :model-settings (nth 10 sections) :delta-tick (nth 11 sections)))) + +;;; INTERFACE PARSER + +(defparameter *widget-parsers* nil) + +(defmacro defwidget-definition (type &rest definitions) + (let + ((lines (gensym))) + `(progn + (defstruct ,type + ,@(remove nil + (mapcar + (lambda (def) (when (find (car def) (list :int :double :boolean :choice :string)) (second def))) + definitions))) + (push + (list + (lambda (,lines) + (and + ,@(remove nil + (mapcar + (lambda (def n) + (let + ((line `(nth ,n ,lines))) + (case (car def) + (:specified `(string= ,(second def) ,line)) + (:int `(parse-integer ,line :junk-allowed t)) + (:double `(ignore-errors (coerce (read-from-string ,line) 'double-float))) + (:boolean `(or (string= "1" ,line) (string= "0" ,line))) + (:choice `(find ,line ',(mapcar #'car (third def)) :test #'string=))))) + definitions + (loop for i to (length definitions) collect i))))) + (lambda (,lines) + (,(read-from-string (format nil "make-~A" type)) + ,@(apply #'append + (mapcar + (lambda (def n) + (let* + ((line `(nth ,n ,lines)) + (val-getter + (case (car def) + (:int `(parse-integer ,line)) + (:double `(coerce (read-from-string ,line) 'double-float)) + (:boolean `(string= "1" ,line)) + (:choice `(cadr (find ,line ',(third def) :key #'car :test #'string=))) + (:string line)))) + (when val-getter (list (intern (symbol-name (cadr def)) :keyword) val-getter)))) + definitions + (loop for i to (length definitions) collect i)))))) + *widget-parsers*)))) + +(defwidget-definition view + (:specified "GRAPHICS-WINDOW") + (:int left) + (:int top) + (:int right) + (:int bottom) + (:reserved "-1") + (:reserved "-1") + (:double patch-size) + (:reserved) + (:int font-size) + (:reserved) + (:reserved) + (:reserved) + (:reserved) + (:boolean wrapping-allowed-in-x) + (:boolean wrapping-allowed-in-y) + (:reserved) + (:int min-pxcor) + (:int max-pxcor) + (:int min-pycor) + (:int max-pycor) + (:choice update-mode (("0" :continuous) ("1" :tick-based))) + (:dump update-mode) + (:boolean show-tick-counter) + (:string tick-counter-label) + (:double frame-rate 30)) + +(defun parse-interface (interface-as-strings) + (let + ((widgets-as-strings + (labels + ((separate-widgets-as-strings (lines &optional widget-as-strings) + (when lines + (if (string= "" (car lines)) + (cons widget-as-strings (separate-widgets-as-strings (cdr lines))) + (separate-widgets-as-strings (cdr lines) (append widget-as-strings (list (car lines)))))))) + (separate-widgets-as-strings interface-as-strings)))) + (remove + nil + (mapcar + (lambda (widget-as-strings) + (let + ((parser (find-if (lambda (validator) (funcall validator widget-as-strings)) *widget-parsers* :key #'car))) + (when parser (funcall (cadr parser) widget-as-strings)))) + widgets-as-strings)))) diff --git a/src/main/package.lisp b/src/main/package.lisp index dcebaf8..83df57f 100644 --- a/src/main/package.lisp +++ b/src/main/package.lisp @@ -1,5 +1,5 @@ (defpackage #:clnl (:use :common-lisp) - (:export :run :boot :run-commands :run-reporter) + (:export #:run #:boot #:run-commands #:run-reporter) (:documentation "Main CLNL package @@ -8,7 +8,7 @@ the place that ties all the parts together into a cohesive whole.")) (defpackage #:clnl-parser (:use :common-lisp) - (:export :parse) + (:export #:parse) (:documentation "CLNL Parser @@ -28,7 +28,7 @@ to match how java.util.Random works. Turtles, all the way down.")) (defpackage #:clnl-transpiler (:use :common-lisp) - (:export :transpile-commands :transpile-reporter) + (:export #:transpile-commands #:transpile-reporter) (:documentation "CLNL Transpiler @@ -49,7 +49,7 @@ into an ast that can be transpiled later.")) (defpackage #:clnl-nvm (:use :common-lisp) - (:export :export-world :create-world :current-state + (:export #:export-world #:create-world #:current-state ; API as used by transpiled NetLogo programs #:ask #:create-turtles @@ -64,7 +64,7 @@ NetLogo Virtual Machine: the simulation engine.")) (defpackage #:clnl-lexer (:use :common-lisp) - (:export :lex) + (:export #:lex) (:documentation "CLNL Lexer @@ -72,7 +72,7 @@ The primary code responsible for tokenizing NetLogo code.")) (defpackage #:clnl-interface (:use :common-lisp) - (:export :run :export-view) + (:export #:run #:export-view) (:documentation "CLNL Interface @@ -82,7 +82,7 @@ components.")) (defpackage #:clnl-cli (:use :common-lisp :cl-charms/low-level) - (:export :run) + (:export #:run) (:documentation "CLNL CLI @@ -92,7 +92,7 @@ is where all the features that the traditional NetLogo UI lives.")) (defpackage #:clnl-model (:use :common-lisp :cl-charms/low-level) - (:export :read-from-nlogo) + (:export #:read-from-nlogo) (:documentation "CLNL Model diff --git a/src/test/package.lisp b/src/test/package.lisp index 2d31027..ea018f9 100644 --- a/src/test/package.lisp +++ b/src/test/package.lisp @@ -1,2 +1,2 @@ (defpackage #:clnl-test (:use :common-lisp) - (:export :run-all-tests :run :test-debug)) + (:export #:run-all-tests #:run #:test-debug)) diff --git a/wiki b/wiki index ca48280..769e5e8 160000 --- a/wiki +++ b/wiki @@ -1 +1 @@ -Subproject commit ca4828046b38fc4f505d0ff3931a16aaf9a85e23 +Subproject commit 769e5e8f99137d05ee9ea7eb5232d923f14b6286