(defpackage #:opengl-2d
  (:use :lispbuilder-regex :lispbuilder-lexer :lispbuilder-opengl :cl))

(in-package #:opengl-2d)

;; Application specific parameters
(defparameter *screen-width* 640)
(defparameter *screen-height* 480)

;;; Begin macro definitions.
; Many thanks, Chris Double
(defmacro with-glBegin (type &body body)
  `(progn
     (gl::glBegin ,type)
     (unwind-protect
	 (progn ,@body)
       (gl::glEnd))))

(defmacro with-glPushMatrix (&body body)
  `(progn
     (gl::glPushMatrix)
     (unwind-protect
	 (progn ,@body)
       (gl::glPopMatrix))))

;;; End macro definitions
;;;

(defun sfloat (number)
  (coerce number 'single-float))

(defun vertex2 (x y)
  (gl::glVertex2f (sfloat x) (sfloat y)))

(defun color-rgb (r g b)
  (gl::glColor3f (sfloat (/ r 256.0)) (sfloat (/ g 256.0)) (sfloat (/ b 256.0))))

(deflexer svg-path-lexer
  :flex-compatible
  ("M" (return :move-to))
  ("C" (return :curve-to))
  ("L" (return :line-to))
  ("[+-]?[:digit:]+\\.?[:digit:]*" (return (float (num %0))))
  ("#\Newline")
  ("."))

(defun parse-svg-path (path-string)
  (loop with lexer = (svg-path-lexer path-string) collect
        (let* ((token (funcall lexer))
               (count (if (member token '(:move-to :line-to)) 1 3)))
          (unless token (loop-finish))
          `(,token ,@(loop for i from 1 to count
                           collect (list (funcall lexer)
                                         (funcall lexer)))))))

(defun generate-svg-path (path)
  (let ((out (make-array '(0) :element-type 'base-char
                         :fill-pointer 0 :adjustable t)))
    (with-output-to-string (s out)
      (loop for (command . points) in path do
            (cond ((eql command :move-to)
                   (destructuring-bind ((x1 y1)) points
                     (format t "M ~a,~a " x1 y1)))
                  ((eql command :line-to)
                   (destructuring-bind ((x1 y1)) points
                     (format t "L ~a,~a " x1 y1)))
                  ((eql command :curve-to)
                   (destructuring-bind ((x1 y1) (x2 y2) (x3 y3)) points
                     (format t "C ~a,~a ~a,~a ~a,~a " x1 y1 x2 y2 x3 y3))))))
    out))

(defun draw-bezier (x0 y0 x1 y1 x2 y2 x3 y3)
  (let* ((cx (* 3 (- x1 x0)))
         (bx (- (* 3 (- x2 x1)) cx))
         (ax (- x3 x0 cx bx))
         (cy (* 3 (- y1 y0)))
         (by (- (* 3 (- y2 y1)) cy))
         (ay (- y3 y0 cy by)))
    (loop for i from 1 to 40 do
          (let* ((s (/ i 40.0))
                 (xs (+ (* s (+ (* s (+ (* s ax) bx)) cx)) x0))
                 (ys (+ (* s (+ (* s (+ (* s ay) by)) cy)) y0)))
            (vertex2 xs ys)))))

(defun draw-path (path)
  (let ((x0 0)
        (y0 0))
    (loop for (command . points) in path do
          (cond ((member command '(:move-to :line-to))
                 (destructuring-bind ((x1 y1)) points
                   (vertex2 x1 y1)
                   (setf x0 x1
                         y0 y1)))
                ((eql command :curve-to)
                 (destructuring-bind ((x1 y1) (x2 y2) (x3 y3)) points
                   (draw-bezier x0 y0 x1 y1 x2 y2 x3 y3)
                   (setf x0 x3
                         y0 y3)))))))

(defun draw-flag (scale)
  (gl::glScalef (sfloat scale) (sfloat scale) 0.0)
  (let ((flagpole (quote #.(parse-svg-path "M -60.6,-120.9 C -56.3,-119.6 -53.4,-115.3 -55.7,-107.3 L -122.1,112.4 C -124.5,120.4 -127.9,122.0 -132.2,120.7 C -136.6,119.4 -140.2,115.8 -137.8,107.7 L -71.4,-111.9 C -69.0,-120.0 -65.0,-122.2 -60.6,-120.9"))))
    (color-rgb #xe0 #x77 #x3e)
    (with-glBegin gl::GL_POLYGON
      (draw-path flagpole))
    (gl::glLineWidth (sfloat (* scale 4.0)))
    (color-rgb 0 0 0)
    (with-glBegin gl::GL_LINE_STRIP
      (draw-path flagpole)))
  (color-rgb #x69 #x74 #xda)
  (gl::glLineWidth (sfloat (* scale 7.0)))
  (with-glBegin gl::GL_LINE_STRIP
    (draw-path (quote #.(parse-svg-path "M -85.1,-9.4 C -47.9,2.1 -13.0,-22.2 8.4,-8.7 C 29.9,4.8 48.6,24.1 82.3,21.0 C 115.6,18.0 158.2,1.9 158.2,1.9 C 158.2,1.9 116.3,-16.1 98.3,-36.7 C 80.2,-57.2 71.7,-78.4 40.0,-89.8 C -3.0,-105.2 -39.2,-95.5 -57.0,-105.6 L -85.1,-9.4"))))
  (gl::glLineWidth (sfloat (* scale 7.0)))
  (color-rgb 0 0 0)
  (with-glBegin gl::GL_LINE_STRIP
    (draw-path (quote #.(parse-svg-path "M -46.6,-90.0 L -65.1,-23.5 L -31.8,-27.3"))))
  (with-glBegin gl::GL_LINE_STRIP
    (draw-path (quote #.(parse-svg-path "M -3.5,-86.5 L -14.8,-27.8 "))))
  (with-glBegin gl::GL_LINE_STRIP
    (draw-path (quote #.(parse-svg-path "M 46.7,-64.7 C 39.6,-75.0 13.4,-90.7 10.7,-68.5 C 8.0,-46.4 50.8,-51.8 40.2,-25.2 C 31.6,-3.5 3.8,-32.6 3.8,-32.6"))))
  (with-glBegin gl::GL_LINE_STRIP
    (draw-path (quote #.(parse-svg-path "M 50.7,2.0 L 62.7,-53.9 C 62.7,-53.9 90.3,-33.8 84.6,-20.4 C 76.8,-2.3 57.9,-27.5 57.9,-27.5")))))

(defun draw-objects ()
  (with-glPushMatrix
    (gl::glTranslatef 200.0 170.0 0.0)
    (draw-flag 1.2))
  (with-glPushMatrix
    (gl::glTranslatef 440.0 340.0 0.0)
    (draw-flag 1.0))
  (with-glPushMatrix
    (gl::glTranslatef 170.0 280.0 0.0)
    (draw-flag 0.4))
  (with-glPushMatrix
    (gl::glTranslatef 500.0 120.0 0.0)
    (draw-flag 0.7)))

(defun draw-screen ()
  (gl::glClearColor 1.0 1.0 1.0 0.0)
  (gl::glClear (sdl::set-flags gl::GL_COLOR_BUFFER_BIT gl::GL_DEPTH_BUFFER_BIT))
  (with-glBegin gl::GL_QUADS
    (color-rgb #xff #xff #xff)
    (vertex2 0 0)
    (vertex2 *screen-width* 0)
    (color-rgb #x69 #xda #x74)
    (vertex2 *screen-width* *screen-height*)
    (vertex2 0 *screen-height*))
  (draw-objects)
  (sdl::SDL_GL_SwapBuffers))
         
(defun setup-opengl (width height)
  (gl::glViewport 0 0 width height)
  (gl::glMatrixMode gl::GL_PROJECTION)
  (gl::glLoadIdentity)
  (gl::glOrtho 0.0 (sfloat width) (sfloat height) 0.0 0.0 1.0)
  (gl::glEnable gl::GL_LINE_SMOOTH)
  (gl::glEnable gl::GL_BLEND)
  (gl::glShadeModel gl::GL_SMOOTH)
  (gl::glBlendFunc gl::GL_SRC_ALPHA gl::GL_ONE_MINUS_SRC_ALPHA))

(defun test ()
  (sdl::with-init ()
    (sdl::set-window *screen-width* *screen-height* :flags sdl::SDL_OPENGL)
    (setup-opengl *screen-width* *screen-height*)
    (sdl::with-events
      (:quit t)
      (:keydown (state scancode key mod unicode)
       (sdl::push-quitevent))
      (:idle             
       (draw-screen)))))