;(declaim (sb-ext:muffle-conditions sb-ext:compiler-note))

(require :sdl)
(require :opengl)
(require :sdl-ttf)

;; Frames per second counting

(defstruct fps
  "Frames-per-second counter"
  (frames 0)
  (start-time (get-universal-time))
)

(defun incf-fps (fps)
  "Increment FPS counter. When 5s elapsed, print stats and reset counter"
  (let* ((time (get-universal-time))
         (delta (- time (fps-start-time fps))))
    (incf (fps-frames fps))
    (when (>= delta 5)
;      (format t "~&~A frames in ~A seconds = ~A FPS~%"
;              (fps-frames fps) delta (float (/ (fps-frames fps) delta)))
      (setf (fps-frames fps) 0
            (fps-start-time fps) time))
    fps))


;; Fonts

(defconstant +font-filename+ "VeraSe.ttf")
(defconstant +font-ptsize+ 16)
(defconstant +nglyphs+ 128 "Number of glyphs in a font")

(defstruct font
  ; (struct TTF_Font *)  [sic]
  (ttf (ttf:open-font +font-filename+ +font-ptsize+))

  ; array of GL texture names for all glyphs
  (textures (sgum:allocate-foreign-object gl:uint +nglyphs+))

  ; number (not alien) of the display list that draws the first glyph on a quad
  (list-base 0)
)

(defun power-of-two (input)
  "Round a number up to the nearest power of two"
  (let ((value 1))
    (loop while (< value input)
      do (setq value (* 2 value))
      )
    value)
)

;(defparameter *area* (sgum:allocate-foreign-object sdl:rect 1))
; these are always zero (we always blit from the start of the source surface)
;(setf (sdl:rect-x *area*) 0)
;(setf (sdl:rect-y *area*) 0)

(declaim (inline prepare-gl-texture))
(defun prepare-gl-texture (insurf)
  "Create a new surface suitable for use as an OpenGL texture.
   Height and width will be powers of two, min size 64x64"
  (let* ((w (max 64 (power-of-two (sdl:surface-w insurf))))
         (h (max 64 (power-of-two (sdl:surface-h insurf))))
         ; assumes little endian
         (outsurf (sdl:create-rgb-surface sdl:+swsurface+ w h 32 #x000000FF #x0000FF00 #x00FF0000 #xFF000000))
         (pixel-format (sdl:surface-format outsurf))
         (area (sgum:allocate-foreign-object sdl:rect 1))
         )

    ; define area to blit from
    (setf (sdl:rect-x area) 0)
    (setf (sdl:rect-y area) 0)
    (setf (sdl:rect-w area) (sdl:surface-w insurf))
    (setf (sdl:rect-h area) (sdl:surface-h insurf))

    ;(sdl:fill-rect outsurf *area* (sdl:map-rgba pixel-format 0 0 0 0))

    (sdl:set-alpha insurf 0 255)

    (sdl:blit-surface insurf area outsurf area)

    outsurf
  )
)

(defparameter *white* (sgum:allocate-foreign-object sdl:color 1))
(setf (sdl:color-r *white*) 255)
(setf (sdl:color-g *white*) 255)
(setf (sdl:color-b *white*) 255)
(defparameter *black* (sgum:allocate-foreign-object sdl:color 1))
(setf (sdl:color-r *black*) 0)
(setf (sdl:color-g *black*) 0)
(setf (sdl:color-b *black*) 0)
(defparameter *red* (sgum:allocate-foreign-object sdl:color 1))
(setf (sdl:color-r *red*) 255)
(setf (sdl:color-g *red*) 0)
(setf (sdl:color-b *red*) 0)
(defparameter *gray* (sgum:allocate-foreign-object sdl:color 1))
(setf (sdl:color-r *gray*) 128)
(setf (sdl:color-g *gray*) 128)
(setf (sdl:color-b *gray*) 128)
(defparameter *green* (sgum:allocate-foreign-object sdl:color 1))
(setf (sdl:color-r *green*) 0)
(setf (sdl:color-g *green*) 255)
(setf (sdl:color-b *green*) 0)


(defparameter *char-advance* (sgum:allocate-foreign-object gl:int 1))
(defparameter *char-minx* (sgum:allocate-foreign-object gl:int 1))
(defparameter *char-maxx* (sgum:allocate-foreign-object gl:int 1))
(defparameter *char-miny* (sgum:allocate-foreign-object gl:int 1))
(defparameter *char-maxy* (sgum:allocate-foreign-object gl:int 1))

(defmacro printsurf (a)
    `(format t "~A~%" (loop for row from 0 to (- (sdl:surface-h ,a) 1) 
      collect (loop for col from 0 to (- (sdl:surface-w ,a) 1) 
                collect (format nil "~X" (sdl:get-pixel ,a col row))))))

(defun make-dlist (font ch)
  "Create a display list of a quad, texture-mapped with a single character"
  (let* ((texture-number (sgum:deref-array (font-textures font) gl:uint ch))
         ;(glyphsurf (ttf:render-glyph-blended (font-ttf font) ch (sgum:deref-pointer *white* sdl:color)))
         (glyphsurf (ttf:render-glyph-blended (font-ttf font) ch #x00FFFFFF)) ; #x00BBRRGG
         ;(glyphsurf (ttf:render-glyph-shaded (font-ttf font) ch (sgum:deref-pointer *white* sdl:color) (sgum:deref-pointer *black* sdl:color)))
         ;(glyphsurf (ttf:render-glyph-solid (font-ttf font) ch (sgum:deref-pointer *white* sdl:color)))
         (char-width (sdl:surface-w glyphsurf))
         (char-height (sdl:surface-h glyphsurf))
         (surf (prepare-gl-texture glyphsurf))
         (tex-width (sdl:surface-w surf))
         (tex-height (sdl:surface-h surf))
         ; x and y are texture coordinates (0 .. 1)
         ; for finding input surface within the new output surface.
         ; Use these in your call to gl:tex-coord-2f (the other corner is 0,0)
         (texmaxx (coerce (/ char-width tex-width) 'float))
         (texmaxy (coerce (/ char-height tex-height) 'float))
         )
    (format t "dlist #~A: tex#~A char-width: ~A char-height: ~A tex-width: ~A tex-height: ~A texmaxx: ~A texmaxy: ~A~%"
            ch texture-number char-width char-height tex-width tex-height texmaxx texmaxy)

    ;(sdl:save-bmp glyphsurf (format nil "glyph-~A.bmp" ch))
    ; Create the texture from the character image
    (gl:bind-texture gl:+texture-2d+ texture-number)
    (gl:tex-parameter-i gl:+texture-2d+ gl:+texture-min-filter+ gl:+linear+)
    (gl:tex-parameter-i gl:+texture-2d+ gl:+texture-mag-filter+ gl:+linear+)
    ;(gl:tex-image-2d gl:+texture-2d+ 0 gl:+rgba+ tex-width tex-height 0 gl:+luminance-alpha+ gl:+unsigned-byte+ (sdl:surface-pixels surf))
    ;(printsurf surf)
    ;(sdl:save-bmp surf (format nil "prep-~A.bmp" ch))
    (gl:tex-image-2d gl:+texture-2d+ 0 4 tex-width tex-height 0 gl:+rgba+ gl:+unsigned-byte+ (sdl:surface-pixels surf))
    ;(gl:tex-image-2d gl:+texture-2d+ 0 3 tex-width tex-height 0 gl:+rgba+ gl:+unsigned-byte+ (sdl:surface-pixels surf))
    ;(gl:tex-image-2d gl:+texture-2d+ 0 gl:+rgba+ tex-width tex-height 0 gl:+rgba+ gl:+unsigned-byte+ (sdl:surface-pixels surf))

    ; Create a display list that draws a quad texture-mapped with that character
    (gl:new-list (+ ch (font-list-base font)) gl:+compile+)
    (gl:bind-texture gl:+texture-2d+ texture-number)
    (gl:push-matrix)
    (ttf:glyph-metrics (font-ttf font) ch *char-minx* *char-maxx* *char-miny* *char-maxy* *char-advance*)
    ;(gl:translate-f 0f0 (- (coerce char-height 'single-float)) 0f0)
    ;(gl:translate-f (coerce (sgum:deref-pointer *char-minx* gl:int) 'single-float)
    ;                (coerce (- (ttf:font-ascent (font-ttf font)) (sgum:deref-pointer *char-miny* gl:int)) 'single-float)
    ;                0f0)
    (gl:translate-f (coerce (sgum:deref-pointer *char-minx* gl:int) 'single-float)
                    (coerce (- (sgum:deref-pointer *char-maxy* gl:int)) 'single-float)
                    0f0)
    (gl:color-4f 1f0 1f0 1f0 1f0)
    (gl:begin gl:+quads+)
      (gl:tex-coord-2f 0f0 0f0)
      (gl:vertex-2i 0 0)
      (gl:tex-coord-2f 0f0 texmaxy)
      (gl:vertex-2i 0 char-height)
      (gl:tex-coord-2f texmaxx texmaxy)
      (gl:vertex-2i char-width char-height)
      (gl:tex-coord-2f texmaxx 0f0)
      (gl:vertex-2i char-width 0)
    (gl:end)
    (gl:pop-matrix)
    (gl:translate-f (coerce (sgum:deref-pointer *char-advance* gl:int) 'single-float) 0f0 0f0)
    (gl:end-list)
  )
)

(defun init-font ()
  (let (font)
    (ttf:init)
    (setf font (make-font))
    (gl:gen-textures +nglyphs+ (font-textures font))
    (setf (font-list-base font) (gl:gen-lists +nglyphs+))
    (loop for i from 0 to (- +nglyphs+ 1) do (make-dlist font i))
    font
  )
)

(defparameter *x* 0.0f0)
(defparameter *y* 0.0f0)
(defparameter *z* -6.0f0)

(defparameter *rtri* 0f0)
(defparameter *drtri* 0.2f0)
(defparameter *rquad* 0f0)
(defparameter *drquad* 0.15f0)

; Delta for keyboard scroll
(defparameter *dx* 0.5f0)
(defparameter *dy* 0.5f0)
(defparameter *dz* 0.5f0)
; Delta for mouse scroll
(defparameter *dxm* 0.04f0)
(defparameter *dym* -0.04f0) ; negative for invert mouse
;Rotational position around the x and y axes
(defparameter *xr* 0f0)
(defparameter *yr* 0f0)
; Delta for mouse rotate
(defparameter *dxr* 0.5f0)
(defparameter *dyr* 0.5f0)

; Current mouse position
(defparameter *mx* 0)
(defparameter *my* 0)

; Triangle color
(defparameter *trir* 1f0)
(defparameter *trib* 0f0)
(defparameter *trig* 0f0)
; Square color
(defparameter *quadr* 0f0)
(defparameter *quadb* 1f0)
(defparameter *quadg* 0f0)

(defparameter *font-r* 1f0)
(defparameter *font-g* 1f0)
(defparameter *font-b* 1f0)



;(defparameter *max-key* 0)
; 319 is the highest key code returned by SDL based on experimentation
(defparameter *keys* (make-array sdl:+k-last+ :initial-element nil))
; Mouse buttons
(defparameter *mb* (make-array 7 :initial-element nil))

(defparameter *rp* (sgum:allocate-foreign-object gl:float 4)) ; raster position
(defparameter *rpv* (sgum:allocate-foreign-object gl:boolean)) ; raster position validity


(defparameter *select* nil)
(defparameter *projection-base* (sgum:allocate-foreign-object gl:float 16))
(defparameter *proj-presel* (sgum:allocate-foreign-object gl:double 16))

(defconstant +selection-buffer-len+ 512)
(defun select (surface width height font)
 (let ((buffer (sgum:allocate-foreign-object gl:uint +selection-buffer-len+))
        (viewport (sgum:allocate-foreign-object gl:int 4))
        (hits 0))
  (gl:get-integerv gl:+viewport+ viewport)
  ;(format t "Viewport: ~A~%" (loop for n from 0 to 3 collect (sgum:deref-array viewport gl:int n)))
  (gl:select-buffer +selection-buffer-len+ buffer)
  (gl:render-mode gl:+select+)
  (gl:init-names)
  (gl:push-name 0)
  (gl:matrix-mode gl:+projection+)
  (gl:push-matrix)
  (gl:get-doublev gl:+projection-matrix+ *proj-presel*)
  (gl:load-identity)
  (glu:pick-matrix (coerce *mx* 'double-float)
                   (coerce (- (sgum:deref-array viewport gl:int 3) *my*) 'double-float)
                   1d0 1d0 viewport)
  (gl:get-floatv gl:+projection-matrix+ *projection-base*)
  (format t "Pick matrix:~%")
  (print-4x4-matrix *projection-base*)
  (glu:perspective 45d0
                   (coerce
                    (/ (- (sgum:deref-array viewport gl:int 2)
                          (sgum:deref-array viewport gl:int 0))
                       (- (sgum:deref-array viewport gl:int 3)
                          (sgum:deref-array viewport gl:int 1)))
                    'double-float)
                   0.1d0
                   100.0d0)
  (gl:matrix-mode gl:+modelview+)
  (draw-scene surface width height font)
  (setq nhits (gl:render-mode gl:+render+))
  ;(format t "Hits: ~A~%" hits)
  (setf *select*
        (if (> nhits 0)
            ; get all the names for just the first hit
            (loop for i from 0 to (- (sgum:deref-array buffer gl:uint 0) 1)
              collect (sgum:deref-array buffer gl:uint (+ 3 i))
            )

          ; clicked on empty space, clear selection
          nil
        )
  )

  (format t "Select: ~A~%" *select*)

  (gl:matrix-mode gl:+projection+)
  (gl:load-identity)
  (gl:get-floatv gl:+projection-matrix+ *projection-base*)
  (gl:pop-matrix)
  (gl:matrix-mode gl:+modelview+)

))


(defun move ()
;  (if (= key (char-code #\a))
;      (setf *x* (- *x* *dx*)))
;  (if (= key (char-code #\d))
;      (setf *x* (+ *x* *dx*)))
;  (if (= key (char-code #\w))
;      (setf *y* (+ *y* *dy*)))
;  (if (= key (char-code #\s))
;      (setf *y* (- *y* *dy*)))
  (if (aref *keys* (char-code #\a))
      (decf *x* *dx*))
  (if (aref *keys* (char-code #\d))
      (incf *x* *dx*))
  (if (aref *keys* (char-code #\w))
      (incf *y* *dy*))
  (if (aref *keys* (char-code #\s))
      (decf *y* *dy*))
)

(defun resize (surface width height)
;  (format t "resize ~A ~A~%" width height)
  (when (zerop height)
    (setf height 1))
  (let ((ratio (coerce (/ width height) 'double-float)))
    (gl:viewport 0 0 width height)
    (gl:matrix-mode gl:+projection+)
    (gl:load-identity)
    (gl:get-floatv gl:+projection-matrix+ *projection-base*)
    (glu:perspective 45.0d0 ratio 0.1d0 100.0d0)
    (gl:matrix-mode gl:+modelview+)
    (gl:load-identity)
    t))

(defun enter-2d-mode (width height)
  (gl:push-attrib (logior gl:+enable-bit+ gl:+transform-bit+))
;  (gl:push-attrib gl:+enable-bit+)
  ;(gl:disable gl:+depth-test+)
  (gl:disable gl:+cull-face+)
  (gl:enable gl:+texture-2d+)
    
  ; This allows alpha blending of 2D textures with the scene
  (gl:enable gl:+blend+)
  (gl:blend-func gl:+src-alpha+ gl:+one-minus-src-alpha+)

  ; this is called automatically on resize event
  ;(gl:viewport 0 0 width height)

  (gl:matrix-mode gl:+projection+)
  (gl:push-matrix)
  (gl:load-identity)
  (gl:mult-matrix-f *projection-base*)
  ;(format t "Entering 2D Mode.  Pick Matrix is:~%")
  ;(print-4x4-matrix *projection-base*)

  (gl:ortho 0d0 (coerce width 'double-float)
            (coerce height 'double-float)
            0d0 0d0 1d0)

  (gl:matrix-mode gl:+modelview+)
  (gl:push-matrix)
  (gl:load-identity)

  (gl:tex-env-i gl:+texture-env+ gl:+texture-env-mode+ gl:+modulate+)
)

(defun leave-2d-mode ()
  (gl:matrix-mode gl:+projection+)
  (gl:pop-matrix)

  (gl:matrix-mode gl:+modelview+)
  (gl:pop-matrix)

  (gl:pop-attrib)
)

(defun gl-print (text font)
 (let ((arr (sgum:allocate-foreign-object gl:ubyte (+ (length text) 1))))
  (loop for i from 0 to (- (length text) 1) do (setf (sgum:deref-array arr gl:ubyte i) (char-code (aref text i))))
  (setf (sgum:deref-array arr gl:ubyte (length text)) 0) ;Null terminated
  (gl:push-attrib (logior gl:+list-bit+ gl:+current-bit+ gl:+enable-bit+ gl:+transform-bit+))
  (gl:matrix-mode gl:+modelview+)
  (gl:disable gl:+lighting+)
  (gl:enable gl:+texture-2d+)
  ;(gl:disable gl:+depth-test+)
  (gl:enable gl:+blend+)
  ;(gl:disable gl:+blend+)
  ;(gl:blend-func gl:+src-alpha+ gl:+one-minus-src-alpha+)
  ;(gl:blend-func gl:+one+ gl:+zero+)
  (gl:blend-func gl:+src-alpha+ gl:+one+)
  ;(gl:blend-func gl:+one-minus-src-alpha+ gl:+src-alpha+)
  (gl:color-4f 1f0 1f0 1f0 1f0)
  ;(gl:translate-f 0f0 0f0 -0.11f0)
  (gl:list-base (font-list-base font))
  (gl:call-lists (length text) gl:+unsigned-byte+ arr)
  (gl:pop-attrib)
 )
)


(defstruct pos (x 0f0) (y 0f0) (z 0f0))
(defstruct color (r 0f0) (g 0f0) (b 0f0) (a 1f0))

(defclass globj ()
  ((pos :initarg :offset :accessor pos)
   (color :initarg :color :accessor color)
   (vertices :initarg :vertices :accessor vertices)
   (primitive :initarg :primitive :accessor primitive)
   ;(label)
   (selected :initform nil :accessor selected)
  )
)

(defgeneric draw (obj width height))

(defclass glshape (globj)
  nil
)

(defmethod draw ((obj globj) width height)
  (gl:color-4f (color-r (color obj)) (color-g (color obj)) (color-b (color obj)) (color-a (color obj)))
)

(defmethod draw ((obj glshape) width height)
  (call-next-method)
  (gl:translate-f (pos-x (pos obj)) (pos-y (pos obj)) (pos-z (pos obj)))
  (unless (null (vertices obj))
    (progn
      (gl:begin (primitive obj))
      (mapc #'(lambda (coords) (apply #'gl:vertex-3f coords)) (vertices obj))
      (gl:end)))      
)

(defun invert-colors (color)
  (setf (color-r color) (- 1f0 (color-r color)))
  (setf (color-g color) (- 1f0 (color-g color)))
  (setf (color-b color) (- 1f0 (color-b color)))
)

(defmethod handle-select ((obj globj) subnames)
  (setf (selected obj) t)
)

(defmethod handle-select ((obj glshape) subnames)
  (invert-colors (color obj))
  (call-next-method)
)

(defclass gltext (globj)
  ((text :initarg :text :accessor text)
   (font :initarg :font :accessor font)
   (height :initform nil :accessor height)
   (width :initform nil :accessor width)
   (point :initform 0 :accessor point)) ; cursor pos is left of the character at index point
)

(defmethod handle-select ((obj gltext) subnames)
  (setf (point obj)
        (if (null subnames)
            ;clicked near the text, but not on any character
            (length (text obj))
          (car subnames)))
  (format t "Set point to ~A~%" (point obj))
  (call-next-method)
)

(defmethod draw ((obj gltext) width height)
  (call-next-method)
  (let (;(modelmatrix (sgum:allocate-foreign-object gl:double 16))
        ;(projmatrix (sgum:allocate-foreign-object gl:double 16))
        (projmatrix *proj-presel*)
        (modelmatrix *mvm*)
        (viewport (sgum:allocate-foreign-object gl:int 4))
        (winx (sgum:allocate-foreign-object gl:double 1))
        (winy (sgum:allocate-foreign-object gl:double 1))
        (winz (sgum:allocate-foreign-object gl:double 1))
        (pos (pos obj))
        x y z
        )

    ;(gl:get-doublev gl:+projection-matrix+ projmatrix)
    ;(gl:get-doublev gl:+modelview-matrix+ modelmatrix)
    (gl:get-integerv gl:+viewport+ viewport)

    (glu:project (coerce (pos-x pos) 'double-float)
                 (coerce (pos-y pos) 'double-float)
                 (coerce (pos-z pos) 'double-float)
                 modelmatrix
                 projmatrix
                 viewport
                 winx winy winz)

    (setf x (sgum:deref-pointer winx gl:double))
    (setf y (sgum:deref-pointer winy gl:double))
    (setf z (sgum:deref-pointer winz gl:double))

    ;(format t "projected text to: <~A,~A,~A>~%" x y z)
            

  ;(gl:translate-f (pos-x (pos obj)) (pos-y (pos obj)) (pos-z (pos obj)))
  ;(unless (= 0f0 *z*)
  ;  (gl:raster-pos-3f 0f0 0f0 0f0))

  ;(gl:get-floatv gl:+current-raster-position+ *rp*)

  (enter-2d-mode width height)
  (gl:color-4f (color-r (color obj)) (color-g (color obj)) (color-b (color obj)) (color-a (color obj)))
  (gl:enable gl:+texture-2d+)
  ;(gl:translate-f (sgum:deref-array *rp* gl:float 0)
  ;                (- height (raster-y))
  ;                0f0)
  (gl:translate-d x (- height y) 0d0)
  (gl:push-matrix)
  ;(gl-print (text obj) (font obj))
  (gl:push-attrib (logior gl:+list-bit+ gl:+current-bit+ gl:+enable-bit+ gl:+transform-bit+))
  ;(gl:matrix-mode gl:+modelview+)
  (gl:disable gl:+lighting+)
  (gl:enable gl:+blend+)
  (gl:blend-func gl:+src-alpha+ gl:+one+)
  (gl:color-4f 1f0 1f0 1f0 1f0)
  ;(gl:call-lists (length text) gl:+unsigned-byte+ arr)
  (let* ((text (text obj))
         (font (font obj))
         (width 0)
         (height (ttf:font-height (font-ttf font)))
         (char-advance (sgum:allocate-foreign-object gl:int 1))
         (ascent (ttf:font-ascent (font-ttf font)))
         (top (- ascent))
         (bottom (+ top height))
        )
    ;(setf (sgum:deref-pointer char-advance gl:int) 0)
    (loop for i from 0 to (length text) do
      (gl:disable gl:+texture-2d+)
      (if (and (selected obj) (= i (point obj)) (cursor-visible))
          ; draw cursor here
          (progn
            (gl:color-4f 1f0 1f0 1f0 1f0)
              (gl:begin gl:+lines+)
              (gl:vertex-2i 0 bottom)
              (gl:vertex-2i 0 top)
            (gl:end)))
      when (<= i (- (length text) 1)) do
      (let ((ch (char-code (aref text i))))
        (ttf:glyph-metrics (font-ttf font) ch nil nil nil nil char-advance)
        (incf width (sgum:deref-pointer char-advance gl:int))
        ; draw invisible box around each half of the letter so clicking that half moves point
        (gl:color-4f 0f0 0f0 0f0 0f0)
        (let* ((full (sgum:deref-pointer char-advance gl:int))
               (half (round (/ full 2))))
          ;(format t "top: ~A bottom: ~A~%" top bottom)
          (gl:push-name i)
          (gl:begin gl:+quads+)
            (gl:vertex-2i 0 bottom)
            (gl:vertex-2i 0 top)
            (gl:vertex-2i half top)
            (gl:vertex-2i half bottom)
          (gl:end)
          (gl:load-name (+ i 1))
          (gl:begin gl:+quads+)
            (gl:vertex-2i half bottom)
            (gl:vertex-2i half top)
            (gl:vertex-2i full top)
            (gl:vertex-2i full bottom)
          (gl:end)
          )
        (gl:enable gl:+texture-2d+)
        (gl:call-list (+ ch (font-list-base font)))
        (gl:pop-name)
        ))
;    (format t "Text width: ~A, Height: ~A~%" width height)
    (setf (width obj) width)
    (setf (height obj) height)

  (gl:pop-attrib)
  (gl:pop-matrix)
  (gl:disable gl:+texture-2d+)
  (if (selected obj)
      (gl:color-4f 0.5f0 0.5f0 0.5f0 0.5f0)
    (gl:color-4f 0f0 0f0 0f0 0f0))
  (gl:begin gl:+quads+)
    (gl:vertex-2i 0 bottom)
    (gl:vertex-2i 0 top)
    (gl:vertex-2i (width obj) top)
    (gl:vertex-2i (width obj) bottom)
  (gl:end)
  (leave-2d-mode)
)))

; TODO: make this blink
(defun cursor-visible () t)

(defun init-scene (font)
  (let ((red (make-color))
        (blue (make-color)))
    (setf (color-r red) 1f0)
    (setf (color-b blue) 1f0)
    (let ((triangle (make-instance 'glshape
                                   :primitive gl:+triangles+
                                   :vertices '((0f0 1f0 0f0) (-1f0 -1f0 0f0) (1f0 -1f0 0f0))
                                   :color red
                                   :offset (make-pos :x -1.5f0 :z 0f0)))
          (square (make-instance 'glshape 
                                 :primitive gl:+quads+
                                 :vertices '((-1f0 -1f0 0f0) (-1f0 1f0 0f0) (1f0 1f0 0f0) (1f0 -1f0 0f0))
                                 :color (copy-color blue)
                                 :offset (make-pos :x 1.5f0 :z 0f0)))
          (sentence (make-instance 'gltext
                                   :font font
                                   :text "Hello, CLOS."
                                   :color (make-color :r 1f0 :g 1f0 :b 1f0)
                                   :offset (make-pos)))
          (sentence2 (make-instance 'gltext
                                    :font font
                                    :text "The quick brown fox jumped over the lazy dog."
                                    :color (copy-color red)
                                    :offset (make-pos :y 3f0)))
          )

      (list triangle square sentence2 sentence)
  )
))


(defparameter *scene* nil)

(defparameter *mvm* (sgum:allocate-foreign-object gl:double 16))

(defun make-brush (font)
  #'(lambda (x y)
      (let ((winx (coerce x 'double-float))
            (winy (coerce y 'double-float))
            ;(winz 0.06006006006d0)
            ;(winz 0.0d0)
            winz
            (modelmatrix *mvm*)
            (projmatrix (sgum:allocate-foreign-object gl:double 16))
            (viewport (sgum:allocate-foreign-object gl:int 4))
            (x1p (sgum:allocate-foreign-object gl:double 1))
            (y1p (sgum:allocate-foreign-object gl:double 1))
            (z1p (sgum:allocate-foreign-object gl:double 1))
            (x2p (sgum:allocate-foreign-object gl:double 1))
            (y2p (sgum:allocate-foreign-object gl:double 1))
            (z2p (sgum:allocate-foreign-object gl:double 1))
            objx objy xslope yslope x1 y1 x2 y2 z1 z2
            realy zdist)

        ;(gl:get-doublev gl:+modelview-matrix+ modelmatrix)
        (gl:get-doublev gl:+projection-matrix+ projmatrix)
        (gl:get-integerv gl:+viewport+ viewport)
        (setf realy (- (sgum:deref-array viewport gl:int 3) winy 1))
        ;(setf realy winy)
        (setf winz 0.0d0)
        (glu:unproject winx realy winz modelmatrix projmatrix viewport x1p y1p z1p)
        (setf winz 1.0d0)
        (glu:unproject winx realy winz modelmatrix projmatrix viewport x2p y2p z2p)
        (setf x1 (sgum:deref-pointer x1p gl:double))
        (setf y1 (sgum:deref-pointer y1p gl:double))
        (setf z1 (sgum:deref-pointer z1p gl:double))
        (setf x2 (sgum:deref-pointer x2p gl:double))
        (setf y2 (sgum:deref-pointer y2p gl:double))
        (setf z2 (sgum:deref-pointer z2p gl:double))
        (format t "near clip point: <~A,~A,~A>~%" x1 y1 z1)
        (format t "far clip point: <~A,~A,~A>~%" x2 y2 z2)
        (push (make-instance 'globj
                       :primitive gl:+lines+
                       :vertices `((,(coerce x1 'single-float)
                                    ,(coerce y1 'single-float)
                                    ,(coerce z1 'single-float)) 
                                   (,(coerce x2 'single-float)
                                    ,(coerce y2 'single-float) 
                                    ,(coerce z2 'single-float)))
                       :color (make-color :b 1f0)
                       :offset (make-pos)
                       )
              *scene*)
        
        (setf xslope (/ (- x2 x1) (- z2 z1)))
        (setf yslope (/ (- y2 y1) (- z2 z1)))
        (setf objz 0.0d0)
        (setf zdist (- objz z1))
        (setf objx (+ x1 (* xslope zdist)))
        (setf objy (+ y1 (* yslope zdist)))
        (format t "positioning...obj=<~A,~A,~A>~%"
                objx objy objz)
        ;(make-instance 'globj
        ;               :primitive gl:+triangles+
        ;               :vertices '((0f0 1f0 0f0) (-1f0 -1f0 0f0) (1f0 -1f0 0f0))
        ;               :color (make-color :r 1f0)
        (make-instance 'gltext
                       :font font
                       :text ""
                       :color (make-color :r 1f0 :g 1f0 :b 1f0 :a 1f0)
                       :offset (make-pos :x (coerce objx 'single-float)
                                         :y (coerce objy 'single-float)
                                         :z (coerce objz 'single-float)
                                                    ))
        )
      )
)

(defparameter *brush* nil)

(defun add-object (scene x y)
  (let ((obj (funcall *brush* x y)))
    ; draw text last so you can see the scene through it
          (if (eq 'gltext (type-of obj))
              (progn
               (setf *scene* (append *scene* (list obj)))
               (setf *select* (list (- (length *scene*) 1))))
            (progn
              (push obj *scene*)
              (setf *select* '(0)))
            )
  )
)

(defun raster-x ()
  (sgum:deref-array *rp* gl:float 0))
(defun raster-y ()
  (sgum:deref-array *rp* gl:float 1))

(defun draw-scene (surface width height font)
  (gl:clear-color 0f0 0f0 0f0 0f0)
  (gl:clear (logior gl:+color-buffer-bit+
                    gl:+depth-buffer-bit+))
  (gl:matrix-mode gl:+modelview+)
  (gl:load-identity)
  (gl:translate-f *x* *y* *z*)
  (gl:rotate-f *xr* 1f0 0f0 0f0)
  (gl:rotate-f *yr* 0f0 1f0 0f0)

  (gl:get-doublev gl:+modelview-matrix+ *mvm*)

  ;(unless (= 0f0 *z*)
  ;  (gl:raster-pos-3f 0f0 0f0 0f0))

  ;(gl:get-floatv gl:+current-raster-position+ *rp*)
  ;(format t "Raster position: ~A~%" (loop for n from 0 to 3 collect (sgum:deref-array *rp* gl:float n)))

  (gl:disable gl:+texture-2d+)

  (loop for i from 0 to (- (length *scene*) 1) do
    (progn
      (gl:load-name i)
      (gl:push-matrix)
      (draw (nth i *scene*) width height)
      (gl:pop-matrix)
      ))
  
  (sdl:gl-swap-buffers)

  ;disable WASD movement since they check "key held" status separately from edit mode
  ;(move)

  t)


(defun print-4x4-matrix (matrix)
  (format t "~%[")
  (loop for i from 0 to 3
    unless (= i 0) do (format t " ")
    do 
    (loop for j from 0 to 3
      do (format t "~A" (sgum:deref-array matrix gl:float (+ i (* j 4))))
      unless (= j 3) do (format t " ")
    )
    when (= i 3) do (format t "]")
    do (format t "~%")
  )
)

(defun shift-p ()
  (or (aref *keys* 304)
      (aref *keys* 303))
)
(defun printable-p (key)
  (and (>= key sdl:+k-space+) (<= key sdl:+k-z+))
)

(defconstant +keymap-shift+
  '((sdl:+k-1+ . #\!)
    (sdl:+k-2+ . #\@)
    (sdl:+k-3+ . #\#)
    (sdl:+k-4+ . #\$)
    (sdl:+k-5+ . #\%)
    (sdl:+k-6+ . #\^)
    (sdl:+k-7+ . #\&)
    (sdl:+k-8+ . #\*)
    (sdl:+k-8+ . #\*)
    (sdl:+k-9+ . #\()
    (sdl:+k-0+ . #\))
    (sdl:+k-minus+ . #\_)
    (sdl:+k-equals+ . #\+)
    (sdl:+k-backslash+ . #\|)
    (sdl:+k-backquote+ . #\~)
    (sdl:+k-comma+ . #\<)
    (sdl:+k-period+ . #\>)
    (sdl:+k-slash+ . #\?)
    (sdl:+k-semicolon+ . #\:)
    (sdl:+k-quote+ . #\")
    (sdl:+k-leftbracket+ . #\{)
    (sdl:+k-rightbracket+ . #\})
))

(defun shifted-key (key)
  (cond
   ((and (>= key sdl:+k-a+) (<= key sdl:+k-z+))
    (code-char (- key 32)))
   (t
    (let ((newkey (find key +keymap-shift+ :test #'(lambda (o zi) (eq o (eval (car zi)))))))
      (if newkey
          (cdr newkey)
        key)))
  )
)

(defun handle-edit (textobj key)
  (let* ((ch (code-char key))
         (text (text textobj))
         (len (length text))
         (point (point textobj))
         (left (subseq text 0 point))
         (right (subseq text point len))
         (mod (sdl:get-mod-state))
         (unprintable-modifiers (logand (lognot sdl:+kmod-shift+) mod))
         )
    (cond
     ; don't add character to string when any modifiers except shift are held down
     ((and (printable-p key) (= unprintable-modifiers 0))
      (setf text (concatenate 'string 
                              left 
                              (string (if (shift-p) (shifted-key key) ch))
                              right))
      (incf (point textobj)))
     ((and (eq ch #\Backspace)
           (> point 0))
      (setf text (concatenate 'string (subseq left 0 (- point 1)) right))
      (decf (point textobj)))

     ((and (eq key sdl:+k-delete+) (< point len))
      (setf text (concatenate 'string left (subseq text (+ point 1) len))))
      
     ((and (> point 0)
           (or (eq key sdl:+k-left+)
               (and (eq key sdl:+k-b+) (logand mod sdl:+kmod-ctrl+))))
      (decf (point textobj)))
     ((and (< point len)
           (or (eq key sdl:+k-right+)
               (and (eq key sdl:+k-f+) (logand mod sdl:+kmod-ctrl+))))
      (incf (point textobj)))
     ((or (eq key sdl:+k-home+)
          (and (eq key sdl:+k-a+) (logand mod sdl:+kmod-ctrl+)))
      (setf (point textobj) 0))
     ((or (eq key sdl:+k-end+)
          (and (eq key sdl:+k-e+) (logand mod sdl:+kmod-ctrl+)))
      (setf (point textobj) len))
     ((and (eq key sdl:+k-u+) (logand mod sdl:+kmod-ctrl+))
      (setf text right)
      (setf (point textobj) 0))
     )
     

    (setf (text textobj) text)
  )

)

(defun unselect ()
  (if *select* (setf (selected (nth (car *select*) *scene*)) nil))
  (setf *select* nil)
)

(defun event-loop (surface width height bpp video-flags fps font)
  (declare (ignorable surface))
  (sdl:event-loop
   (:key-down (key)
              (setf (aref *keys* key) t)
              (format t "Key down: ~A~%" key)

              (cond
               ; Esc always clears selection
               ((= key (char-code #\Esc))
                (progn (unselect)))

               ((and (not (null *select*)) 
                     (eq 'gltext (type-of (nth (car *select*) *scene*))))
                (handle-edit (nth (car *select*) *scene*) key))

	      ((= key (char-code #\q))
                  (return))
              ((= key (char-code #\p))
                  (let ((matrix (sgum:allocate-foreign-object gl:float 16)))
                    (gl:get-floatv gl:+projection-matrix+ matrix)
                    (format t "Projection matrix (before 2D): ")
                    (print-4x4-matrix matrix)))
              ((= key (char-code #\m))
                  (let ((matrix (sgum:allocate-foreign-object gl:float 16)))
                    (gl:get-floatv gl:+modelview-matrix+ matrix)
                    (format t "Model view matrix: ")
                    (print-4x4-matrix matrix)
                    (format t "Stored *mvm*: ")
                    (print-4x4-matrix matrix)
                  )
              )
              ((= key (char-code #\r))
                  (format t "Raster position: ~A~%" (loop for n from 0 to 3 collect (sgum:deref-array *rp* gl:float n))) 
                  )
              ) ;cond

              )
   (:key-up (key)
            (setf (aref *keys* key) nil)
            ;(format t "Key up: ~A~%" key )
            )
   (:mouse-button-up (button x y)
		     ;(format t "Mouse button ~A up at (~A, ~A)~%" button x y)
                     (setf (aref *mb* button) nil))
   (:mouse-button-down (button x y)
		       (format t "Mouse button ~A down at (~A, ~A)~%" button x y)
                       (setf (aref *mb* button) t)
                       (if (= button 5)
                           (setf *z* (- *z* *dz*)))
                       (if (= button 4)
                           (setf *z* (+ *z* *dz*)))
                       (if (= button 1)
                           (progn
                             (unselect)
                             (select surface width height font)
                             (if (null *select*)
                                 (add-object *scene* x y))
                             (handle-select (nth (car *select*) *scene*) (cdr *select*))
                           )
                       )
                       )
   (:mouse-motion (x y xrel yrel state)
                  ;(format t "Mouse motion: x=~A y=~A xrel=~A yrel=~A state=~A~%" x y xrel yrel state)
                  (setf *mx* x)
                  (setf *my* y)
                  (if (aref *mb* 3)
                      (progn
                        (incf *x* (* *dxm* xrel))
                        (incf *y* (* *dym* yrel))
                      )
                  )
                  (if (aref *mb* 2)
                      (progn
                        ; Moving mouse left<->right rotates around Y axis and vice versa
                        (incf *xr* (* *dxr* yrel))
                        (incf *yr* (* *dyr* xrel))
                         ))
                  (if (aref *mb* 1)
                      ; if there is a selected object
                      (if *select*
                        (let ((obj (nth (car *select*) *scene*)))
                          ; drag the selected object
                          (incf (pos-x (pos obj)) (* *dxm* xrel))
                          (incf (pos-y (pos obj)) (* *dym* yrel))
                        )
                      )
                  )
   )
   (:quit ()
	  (return))
   (:resize (width height)
	    (format t "Resized width = ~A height = ~A~%" width height)
            (sdl:free-surface surface)
            (setf surface (sdl:set-video-mode width height bpp video-flags))
            (resize surface width height))
   (:idle ()
	  (progn (draw-scene surface width height font)
                 (incf-fps fps)
                 (sdl:delay 10)
                 ))))

(defun scroll ()
  (let ((width 1024)
        (height 768)
        (video-flags (logior sdl:+opengl+ sdl:+resizable+ sdl:+gl-doublebuffer+ sdl:+hwpalette+))
        (bpp 16)
        fps
        font
        )

  (sdl:init sdl:+init-video+) 

  (multiple-value-bind (hw-available-p blit-hw-p)
      (sdl:query-video-info :hw-available :blit-hw)
    (setf video-flags (logior video-flags
                              (if hw-available-p
                                  sdl:+hwsurface+
                                  sdl:+swsurface+)
                              (if blit-hw-p
                                  sdl:+hwaccel+
                                  0))))

  (sdl:gl-set-attribute sdl:+gl-doublebuffer+ 1)

  (let ((surface (sdl:set-video-mode width height bpp video-flags)))
    (when (sgum:null-pointer-p surface)
      (error "Failed to obtain surface"))

    (gl:enable gl:+texture-2d+)
    (gl:shade-model gl:+smooth+)
    (gl:clear-color 0.0f0 0.0f0 0.0f0 0.0f0)
    (gl:clear-depth 1.0d0)
    (gl:enable gl:+depth-test+)
    (gl:depth-func gl:+lequal+)
    (gl:hint gl:+perspective-correction-hint+ gl:+nicest+)

    (resize surface width height)

    (setf font (init-font))
    (setf *scene* (init-scene font))
    (setf *brush* (make-brush font))

    (gl:matrix-mode gl:+projection+)
    (gl:get-doublev gl:+projection-matrix+ *proj-presel*)

    (sdl:enable-key-repeat sdl:+default-repeat-delay+ sdl:+default-repeat-interval+)

    ; start FPS counter
    (setf fps (make-fps))

    (unwind-protect (event-loop surface width height bpp video-flags fps font)
      (progn (sdl:free-surface surface)
             (sdl:quit)))
    (values))
  )
)

(scroll)