(defvar *patch-list* nil)
(defvar *glut-window-opened* nil)
-(defvar *dimensions* nil)
+(defvar *dimensions* nil) ; This is a useful placeholder for other view properties
+(defvar *window-width* 1024)
+(defvar *window-height* 768)
(defvar *default-shapes* nil)
+(defvar *textbox* nil)
+(defvar *inputbox* nil)
+
+(defvar *current-globals* nil)
+
+(defvar *widgets* nil) ; this is going to be pairs to save the original definition
+
+; This is the thread that does the work of querying the currently running system to update
+; the interface state. We keep it seperate from the main system display thread for two reasons:
+; 1) It should run even if there's no active display
+; 2) We want it to run slower than the current display thread
+(defvar *interface-thread* nil)
+
+(defgeneric update-widget (type def widget extra-info))
+(defmethod update-widget (type def widget extra-info))
+
+(defmethod update-widget ((type (eql :button)) button-def button idx)
+ (when (getf button-def :forever)
+ (clnl-gltk:toggle button (clnl-model:forever-button-on (getf button-def :display) idx))))
+
+(defmethod update-widget ((type (eql :switch)) switch-def switch nothing)
+ (let
+ ((global (find (getf switch-def :var) *current-globals* :key (lambda (def) (getf def :name)))))
+ (clnl-gltk:toggle switch (getf global :value))))
+
+(defun update-interface ()
+ (mapcar
+ (lambda (widget) (apply #'update-widget widget))
+ *widgets*))
+
+(defun boot-interface-thread ()
+ (when (not *interface-thread*)
+ (setf *interface-thread*
+ (sb-thread:make-thread (lambda () (loop (update-interface) (sleep .1))) :name "Interface Thread"))))
+
; For now, shapes can live in here
; header is
; * name <like default>
(nth (floor color 10) *colors*))))
(defun render-scene ()
- (gl:clear :color-buffer-bit :depth-buffer-bit)
(gl:matrix-mode :projection)
- (gl:load-identity)
- (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)
- (mapcar
- (lambda (patch)
- (let
- ((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:call-list *patch-list*)))
- patches)
- (mapcar
- (lambda (turtle)
- (let
- ((color (nl-color->rgb (getf turtle :color))))
- (gl:color (car color) (cadr color) (caddr color)))
+ (gl:with-pushed-matrix
+ (gl:load-identity)
+ (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:with-pushed-matrix
+ (gl:load-identity)
+ (destructuring-bind (turtles patches globals) (clnl-nvm:current-state)
+ (setf *current-globals* globals)
(mapcar
- (lambda (x-modification y-modification)
+ (lambda (patch)
+ (let
+ ((color (nl-color->rgb (getf patch :color))))
+ (gl:color (car color) (cadr color) (caddr color)))
(gl:with-pushed-matrix
- (gl:translate (* (getf turtle :xcor) (patch-size)) (* (getf turtle :ycor) (patch-size)) 0)
- (gl:translate x-modification y-modification 0)
- (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))
+ (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
+ (lambda (turtle)
+ (let
+ ((color (nl-color->rgb (getf turtle :color))))
+ (gl:color (car color) (cadr color) (caddr color)))
+ (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 x-modification y-modification 0)
+ (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)))
+ (gl:matrix-mode :projection))
(gl:flush))
+(defun render-widgets ()
+ (clnl-gltk:render *textbox*)
+ (clnl-gltk:render *inputbox*)
+ (mapcar #'clnl-gltk:render (mapcar #'third *widgets*)))
+
+(defun render ()
+ (gl:clear :color-buffer-bit :depth-buffer-bit)
+ (let
+ ((width (world-width-in-pixels))
+ (height (world-height-in-pixels)))
+ (gl:viewport 0 0 *window-width* *window-height*)
+
+ (gl:matrix-mode :projection)
+ (let*
+ ((left (getf *dimensions* :left))
+ (top (getf *dimensions* :top))
+ (view-x1 left)
+ (view-x2 (+ view-x1 width))
+ (view-y1 (- *window-height* height top))
+ (view-y2 (- *window-height* top)))
+
+ (gl:with-pushed-matrix
+ (gl:load-identity)
+ (gl:ortho 0 *window-width* 0 *window-height* 0 5000)
+ (render-widgets)
+
+ (gl:color 1 1 1)
+ (gl:begin :lines)
+ (gl:vertex view-x1 view-y1)
+ (gl:vertex view-x1 (+ view-y2 1))
+
+ (gl:vertex view-x1 (+ view-y2 1))
+ (gl:vertex (+ view-x2 1) (+ view-y2 1))
+
+ (gl:vertex (+ view-x2 1) (+ view-y2 1))
+ (gl:vertex (+ view-x2 1) (- view-y1 1))
+
+ (gl:vertex (+ view-x2 1) view-y1)
+ (gl:vertex (- view-x1 1) view-y1)
+ (gl:end))
+
+ (gl:viewport view-x1 view-y1 width height)
+ (render-scene))))
+
(defun display ()
- (render-scene)
+ (render)
(cl-glut:swap-buffers))
(defun idle ()
(cl-glut:post-redisplay))
(defun close-func ()
+ ;(glut:leave-main-loop)
(sb-ext:exit :abort t))
(defun reshape (width height)
(when (and (/= 0 width) (/= 0 height))
- (gl:viewport 0 0 width height)))
+ (setf *window-width* width)
+ (setf *window-height* height)
+ (let
+ ((box-width (truncate (- width 12) clnl-gltk:*font-width*)))
+ (clnl-gltk:resize *textbox* box-width 12)
+ (clnl-gltk:resize *inputbox* box-width 1))
+ (mapcar
+ (lambda (widget)
+ (clnl-gltk:reposition (third widget)
+ (getf (second widget) :left)
+ (- *window-height* (getf (second widget) :height) (getf (second widget) :top))))
+ *widgets*)))
+
+(defun execute (str)
+ (setf
+ (clnl-gltk:textbox-text *textbox*)
+ (format nil "> ~A~%~%~A" str
+ (handler-case
+ (with-output-to-string (*standard-output*)
+ (clnl:run-commands str))
+ (error (e) (format nil "Ok, something went wrong: ~A~%Try :help" e))))))
+
+(defun key-pressed (key x y)
+ (declare (ignore x y))
+ (if (eql key 13)
+ (progn
+ (execute (clnl-gltk:value *inputbox*))
+ (clnl-gltk:clear *inputbox*))
+ (clnl-gltk:key-pressed *inputbox* key)))
+
+(defun mouse (button state x y)
+ (declare (ignore button))
+ (mapcar
+ (lambda (w)
+ (when (eql state :down) (clnl-gltk:mousedown w x (- *window-height* y)))
+ (when (eql state :up) (clnl-gltk:mouseup w x (- *window-height* y))))
+ (mapcar #'third *widgets*)))
+
+(defun motion (x y)
+ (mapcar
+ (lambda (w) (clnl-gltk:mousemove w x (- *window-height* y)))
+ (mapcar #'third *widgets*)))
(cffi:defcallback display :void () (display))
(cffi:defcallback idle :void () (idle))
(cffi:defcallback close-func :void () (close-func))
(cffi:defcallback reshape :void ((width :int) (height :int)) (reshape width height))
+(cffi:defcallback key-pressed :void ((key :uchar) (x :int) (y :int)) (key-pressed key x y))
+(cffi:defcallback special-key-pressed :void ((key glut:special-keys) (x :int) (y :int)) (key-pressed key x y))
+(cffi:defcallback mouse :void ((button cl-glut:mouse-button) (state cl-glut:mouse-button-state) (x :int) (y :int))
+ (mouse button state x y))
+
+(cffi:defcallback motion :void ((x :int) (y :int)) (motion x y))
(defun set-turtle-lists ()
(setf
(gl:vertex 1 0 0)
(gl:end)))
-(defun initialize (&key dims)
- "INITIALIZE &key DIMS => RESULT
+(defvar *initial-banner*
+ "
+ / \\
+ / \\ Welcome to CLNL version ~A!
+ / \\
+ /_______\\
+
+CLNL is an experiment at creating an alternate implementation of NetLogo.
+
+You can enter in various netlogo commands below, or use :q to quit the program.
+
+See http://github.com/frankduncan/clnl for more information about CLNL and to
+keep apprised of any updates that may happen.")
+
+(defun button-defs->buttons (button-defs)
+ (let
+ ((known-button-names nil))
+ (mapcar
+ (lambda (button-def)
+ (let*
+ ((idx (length (remove (getf button-def :display) known-button-names :test-not #'equal)))
+ (toggle-button nil)
+ (button
+ (clnl-gltk:button
+ (getf button-def :left)
+ (- *window-height* (getf button-def :height) (getf button-def :top))
+ (getf button-def :width)
+ (getf button-def :height)
+ (getf button-def :display)
+ (lambda ()
+ (when toggle-button (funcall toggle-button))
+ (execute
+ (format nil ":button \"~A\"~A"
+ (getf button-def :display)
+ (if (zerop idx) "" (format nil " ~A" idx)))))
+ :forever (getf button-def :forever))))
+ (push (getf button-def :display) known-button-names)
+ (when (getf button-def :forever) (setf toggle-button (lambda () (clnl-gltk:toggle button))))
+ (list :button button-def button idx)))
+ button-defs)))
+
+(defun switch-defs->switches (switch-defs)
+ (mapcar
+ (lambda (switch-def)
+ (let*
+ ((switch
+ (clnl-gltk:switch
+ (getf switch-def :left)
+ (- *window-height* clnl-gltk:*switch-height* (getf switch-def :top))
+ (getf switch-def :width)
+ (getf switch-def :display)
+ (lambda (state) (execute (format nil "set ~A ~A" (getf switch-def :display) (if state "true" "false"))))
+ (getf switch-def :initial-value))))
+ (list :switch (append switch-def (list :height clnl-gltk:*switch-height*)) switch nil)))
+ switch-defs))
+
+(defun initialize (&key dims view buttons switches)
+ "INITIALIZE &key DIMS VIEW BUTTONS SWITCHES => RESULT
DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX :patch-size PATCH-SIZE)
+ VIEW: (:left LEFT :top TOP)
+ BUTTONS: BUTTON-DEF*
+ SWITCHES: SWITCH-DEF*
+ BUTTON-DEF: (:left LEFT :top TOP :height HEIGHT :width WIDTH :forever FOREVER :display DISPLAY)
+ SWITCH-DEF: (:left LEFT :top TOP :width WIDTH :var VAR :display DISPLAY :initial-value INITIAL-VALUE)
ARGUMENTS AND VALUES:
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
+ HEIGHT: An integer representing height
+ FOREVER: A boolean representing the forever status
+ LEFT: An integer representing the left position
+ TOP: An integer representing the top position
+ WIDTH: An integer representing width
+ VAR: A string representing the variable name
+ DISPLAY: A string representing display name
+ INITIAL-VALUE: The initial value
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)
- (when *glut-window-opened*
- (cl-glut:reshape-window (world-width-in-pixels) (world-height-in-pixels))))
+ (boot-interface-thread)
+ (setf *dimensions* (append dims view))
+ (setf *widgets*
+ (append
+ (button-defs->buttons buttons)
+ (switch-defs->switches switches))))
(defun run ()
"RUN => RESULT
; want to investigate until simply ignoring them becomes a problem.
(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)
- (world-height-in-pixels))
+ (cl-glut:init-window-size *window-width* *window-height*)
(cl-glut:init-display-mode :double :rgba)
(cl-glut:create-window "CLNL Test Window")
(setf *glut-window-opened* t)
(glut:reshape-func (cffi:callback reshape))
(cl-glut:idle-func (cffi:get-callback 'idle))
(cl-glut:close-func (cffi:get-callback 'close-func))
+ (cl-glut:keyboard-func (cffi:get-callback 'key-pressed))
+ (cl-glut:special-func (cffi:get-callback 'special-key-pressed))
+ (cl-glut:motion-func (cffi:get-callback 'motion)) ; while mouse is down
+ (cl-glut:passive-motion-func (cffi:get-callback 'motion)) ; while mouse is up
+ (cl-glut:mouse-func (cffi:get-callback 'mouse)) ; state is up/down, button is button
+ (gl:depth-func :lequal)
+ (gl:blend-func :src-alpha :one-minus-src-alpha)
+ (gl:enable :blend)
(set-turtle-lists)
(set-patch-list)
+ (clnl-gltk:setup)
+ (setf *textbox*
+ (clnl-gltk:textbox
+ 5 (+ clnl-gltk:*font-height* 14)
+ 10 12
+ (format nil *initial-banner* (asdf:component-version (asdf:find-system :clnl)))))
+ (setf *inputbox* (clnl-gltk:inputbox 5 5 10))
(cl-glut:main-loop)))
(defun patch-size () (getf *dimensions* :patch-size))
(let
((fbo (first (gl:gen-framebuffers 1)))
(render-buf (first (gl:gen-renderbuffers 1)))
- ;(width
- ; (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+ (-
- ; (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)
+ (width (world-width-in-pixels))
(height (world-height-in-pixels)))
(gl:bind-framebuffer :framebuffer fbo)
(gl:bind-renderbuffer :renderbuffer render-buf)
projects / clnl / blobdiff