(defvar *glut-window-opened* nil)
(defvar *dimensions* nil)
+(defvar *window-width* 1024)
+(defvar *window-height* 768)
+
+(defvar *default-shapes* nil)
+
+(defvar *textbox* nil)
+(defvar *inputbox* nil)
+
+(defvar *widgets* nil) ; this is going to be pairs to save the original definition
; For now, shapes can live in here
; header is
((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
(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
: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
(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)
(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) (clnl-nvm:current-state)
(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 #'cadr *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)
+ (gl:with-pushed-matrix
+ (gl:load-identity)
+ (gl:ortho 0 *window-width* 0 *window-height* 0 5000)
+ (render-widgets)
+
+ (gl:begin :lines)
+ (gl:vertex (- *window-width* width 10) (- *window-height* height 10))
+ (gl:vertex (- *window-width* width 10) (- *window-height* 9))
+
+ (gl:vertex (- *window-width* width 10) (- *window-height* 9))
+ (gl:vertex (- *window-width* 9) (- *window-height* 9))
+
+ (gl:vertex (- *window-width* 9) (- *window-height* 9))
+ (gl:vertex (- *window-width* 9) (- *window-height* height 10))
+
+ (gl:vertex (- *window-width* 9) (- *window-height* height 10))
+ (gl:vertex (- *window-width* width 10) (- *window-height* height 10))
+ (gl:end))
+
+ (gl:viewport (- *window-width* width 10) (- *window-height* height 10) 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 (pair)
+ (clnl-gltk:reposition (cadr pair)
+ (getf (car pair) :left)
+ (- *window-height* (getf (car pair) :height) (getf (car pair) :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 #'cadr *widgets*)))
+
+(defun motion (x y)
+ (mapcar
+ (lambda (w) (clnl-gltk:mousemove w x (- *window-height* y)))
+ (mapcar #'cadr *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: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))
(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 initialize (&key dims buttons)
+ "INITIALIZE &key DIMS BUTTONS => RESULT
DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX :patch-size PATCH-SIZE)
+ BUTTONS: BUTTON-DEF*
+ BUTTON-DEF: (:left LEFT :top TOP :height HEIGHT :width WIDTH :display DISPLAY)
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
+ LEFT: An integer representing the left position
+ TOP: An integer representing the top position
+ HEIGHT: An integer representing height
+ WIDTH: An integer representing width
+ DISPLAY: A string representing display name
DESCRIPTION:
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))))
+ (let
+ ((known-button-names nil))
+ (setf *widgets*
+ (mapcar
+ (lambda (button-def)
+ (let
+ ((idx (length (remove (getf button-def :display) known-button-names :test-not #'equal))))
+ (push (getf button-def :display) known-button-names)
+ (list
+ button-def
+ (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 ()
+ (execute
+ (format nil ":button \"~A\"~A"
+ (getf button-def :display)
+ (if (zerop idx) "" (format nil " ~A" idx)))))))))
+ buttons))))
(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