X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?a=blobdiff_plain;f=src%2Fmain%2Finterface.lisp;h=330135bc91c5baa4f0ad3848da1980630b15b6f8;hb=31a8f429b5182d9c4f3eae208ccc8efbdfe8a996;hp=0f6fb596b4a1f0ecc9e8f1d506d54f17f04ac71b;hpb=268b16dea9f447b3cf41090c44130d9b60807d7d;p=clnl

diff --git a/src/main/interface.lisp b/src/main/interface.lisp
index 0f6fb59..330135b 100644
--- a/src/main/interface.lisp
+++ b/src/main/interface.lisp
@@ -5,6 +5,15 @@
 
 (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
@@ -46,7 +55,7 @@
   ((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
@@ -131,30 +140,30 @@
       (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
@@ -169,8 +178,10 @@
         :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
@@ -180,6 +191,10 @@
 (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)
@@ -206,70 +221,155 @@
    (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
@@ -288,7 +388,7 @@
       (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))
@@ -300,10 +400,26 @@
   (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:
 
@@ -313,6 +429,11 @@ 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:
 
@@ -321,8 +442,28 @@ 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
@@ -342,9 +483,7 @@ DESCRIPTION:
  ; 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)
@@ -353,8 +492,23 @@ DESCRIPTION:
   (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))
@@ -394,16 +548,7 @@ DESCRIPTION:
   (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)