#|

required changes in package gl:

(defcfun ("glVertex3dv" %glVertex3dv) :void 
  (vertex :pointer))


required changes in package glu:

(defcenum tess-enum
  (:tess-begin 100100)
  (:begin 100100)
  (:tess-vertex 100101)
  (:vertex 100101)
  (:tess-end 100102)
  (:end 100102)
  (:tess-error 100103)
  (:tess-edge-flag 100104)
  (:edge-flag 100104)
  (:tess-combine 100105)
  (:tess-begin-data 100106)
  (:tess-vertex-data 100107)
  (:tess-end-data 100108)
  (:tess-error-data 100109)
  (:tess-edge-flag-data 100110)
  (:tess-combine-data 100111))

(defcfun ("gluTessCallback" %gluTessCallback) :void 
  (tess-obj :pointer)
  (which :int)
  (callback-pointer :pointer))

(defun tess-callback (tess-obj which callback-function)
  (%gluTessCallback tess-obj (foreign-enum-value 'tess-enum which) callback-function))


required changes in cffi:cffi-lispworks.lisp:

- replace all ":cdecl"s with ":stdcall"s (this should be an extra parameter
                                               for the callback macros)


|#

(declaim (optimize (speed 0) (safety 3) (compilation-speed 0) (debug 3)))

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

(in-package #:opengl-2d)

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

(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 (&rest path-strings)
  "Parse a list of strings, interpreted as a SVG path, e.g. 'M 1.5,0 L 20,20', which"
  "means: move to (1.5, 0) and then draw a line to (20, 20). The result is a more"
  "Lisp-like format: ((:MOVE-TO (1.5 0.0)) (:LINE-TO (20.0 20.0)))"
  (let ((path-string (apply #'concatenate (cons 'string path-strings))))
    (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)
  "Generate a SVG path string from the Lisp representation which is produced by"
  "parse-svg-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 draw-function)
  "Generate a bezier curve and call the supplied function for every point."
  (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)))
            (funcall draw-function xs ys)))))

(defparameter *circle-steps* 24)

(defun fill-circle (x y radius)
  (gl:with-primitives :polygon
    (let ((angle (/ (* 2 pi) *circle-steps*)))
      (loop for i from 0 below *circle-steps* do
            (let ((dx (* radius (sin (* angle i))))
                  (dy (* radius (cos (* angle i)))))
              (gl:vertex (+ x dx) (+ y dy)))))))

(defun fill-thick-line (x0 y0 x1 y1 width)
  (let* ((dx (- x1 x0))
         (dy (- y1 y0))
         (d2 (+ (* dx dx) (* dy dy))))
    (when (< 0 d2)
      (let* ((d (sqrt d2))
             (ny (- (* (/ dx d 2) width)))
             (nx (* (/ dy d 2) width)))
        (gl:with-primitives :quads
          (gl:vertex (+ x0 nx) (+ y0 ny))
          (gl:vertex (+ x1 nx) (+ y1 ny))
          (gl:vertex (- x1 nx) (- y1 ny))
          (gl:vertex (- x0 nx) (- y0 ny)))))))

(defun thick-line (x0 y0 x1 y1 width)
  (fill-thick-line x0 y0 x1 y1 width)
  (fill-circle x0 y0 (/ width 2))
  (fill-circle x1 y1 (/ width 2)))

(defun draw-path (path width)
  "Draw a path with OpenGL."
  (let ((x0 0)
        (y0 0))
    (loop for (command . points) in path do
          (cond ((eql command :move-to)
                 (destructuring-bind ((x1 y1)) points
                   (setf x0 x1
                         y0 y1)))
                ((eql command :line-to)
                 (destructuring-bind ((x1 y1)) points
                   (fill-circle x0 y0 (/ width 2))
                   (fill-thick-line x0 y0 x1 y1 width)
                   (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
                                #'(lambda (x y)
                                    (fill-circle x0 y0 (/ width 2))
                                    (fill-thick-line x0 y0 x y width)
                                    (setf x0 x
                                          y0 y)))
                   (setf x0 x3
                         y0 y3)))))
    (fill-circle x0 y0 (/ width 2))))

(defcallback tess-begin-callback :void ((mode :int))
  "Called on start of the tesselation process."
  (gl::%glBegin mode))

(defcallback tess-vertex-callback :void ((vertex :pointer))
  "Called for every vertex of the tesselation process."
  (gl::%glVertex3dv vertex))

(defcallback tess-end-callback :void ()
  "Called on end of the tesselation process."
  (gl:end))

(defcallback tess-error-callback :void ((error :int))
  "Called on tesselation errors (e.g. too large coordinate numbers)."
  (format t "error: ~a~%" error))

(defcallback tess-combine-callback :void
    ((vertex :pointer)
     (data :pointer)
     (weight :pointer)
     (data-out :pointer))
  (declare (ignore data weight))
  "Called when the tesselation needs to combine points. This implementation"
  "just sets the pointer to the provided vertex in data-out."
  "TODO: testing, if it works."
  (setf (mem-aref data-out :pointer) vertex))

(defun fill-tesselated (vertices)
  "Fill an arbitrary 2D polygon with OpenGL and GLU tesselation for"
  "concave polygons."
  (let ((tess-obj (glu::new-tess)))
    (glu::tess-callback tess-obj :tess-begin (callback tess-begin-callback))
    (glu::tess-callback tess-obj :tess-vertex (callback tess-vertex-callback))
    (glu::tess-callback tess-obj :tess-end (callback tess-end-callback))
    (glu::tess-callback tess-obj :tess-combine (callback tess-combine-callback))
    (glu::tess-callback tess-obj :tess-error (callback tess-error-callback))
    (glu::tess-begin-polygon tess-obj (null-pointer))
    (glu::tess-begin-contour tess-obj)
    (with-foreign-object (coords :double (* 3 (length vertices)))
      (loop for vertex in vertices
            with i = 0 do
            (destructuring-bind (x y) vertex
              (setf (mem-aref coords :double (+ i 0)) (coerce x 'double-float))
              (setf (mem-aref coords :double (+ i 1)) (coerce y 'double-float))
              (setf (mem-aref coords :double (+ i 2)) (coerce 0 'double-float)))
            (let ((p (inc-pointer coords (* i (cffi::foreign-type-size :double)))))
              (glu::tess-vertex tess-obj p p))
            (incf i 3))
      (glu::tess-end-contour tess-obj)
      (glu::tess-end-polygon tess-obj)
      (glu::delete-tess tess-obj))))

(defun fill-path (path)
  "Draw a path with OpenGL."
  (let ((x0 0)
        (y0 0))
    (loop for (command . points) in path
          with vertices = '()
          finally (fill-tesselated (nreverse vertices)) do
          (cond ((member command '(:move-to :line-to))
                 (destructuring-bind ((x1 y1)) points
                   (gl:vertex 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
                                #'(lambda (x y)
                                    (push (list x y) vertices)))
                   (setf x0 x3
                         y0 y3)))))))

(defun color-rgb (r g b)
  "Set an OpenGL color with RGB values in the range of 0..255."
  (gl:color (/ r 256) (/ g 256) (/ b 256)))

(defparameter *flag* nil)

(defun create-flag ()
  "Draw a flag with the text 'LISP' on it."
  (setf *flag* (gl:gen-lists 1))
  (gl:new-list *flag* :compile)
  (let ((flag (parse-svg-path "M -90,-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 -58.0,-105.6")))
    ;; use this instead of parse-svg-path, if you don't want to install lispbuilder-lexer
    #|
((:MOVE-TO (-90.0 -9.4))
 (:CURVE-TO (-47.9 2.1) (-13.0 -22.2) (8.4 -8.7))
 (:CURVE-TO (29.9 4.8) (48.6 24.1) (82.3 21.0))
 (:CURVE-TO (115.6 18.0) (158.2 1.9) (158.2 1.9))
 (:CURVE-TO (158.2 1.9) (116.3 -16.1) (98.3 -36.7))
 (:CURVE-TO (80.2 -57.2) (71.7 -78.4) (40.0 -89.8))
 (:CURVE-TO (-3.0 -105.2) (-39.2 -95.5) (-58.0 -105.6)))
|#
    (color-rgb #x69 #x74 #xda)
    (fill-path flag))
  (let ((L (parse-svg-path "M -46.6,-90.0 "
                           "L -65.1,-23.5 "
                           "L -31.8,-27.3"))
        #|
((:MOVE-TO (-46.6 -90.0))
 (:LINE-TO (-65.1 -23.5))
 (:LINE-TO (-31.8 -27.3)))
|#
        (I (parse-svg-path "M -3.5,-86.5 "
                           "L -14.8,-27.8 "))
        #|
((:MOVE-TO (-3.5 -86.5)) (:LINE-TO (-14.8 -27.8)))
|#

        (S (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"))
        #|
((:MOVE-TO (46.7 -64.7))
 (:CURVE-TO (39.6 -75.0) (13.4 -90.7) (10.7 -68.5))
 (:CURVE-TO (8.0 -46.4) (50.8 -51.8) (40.2 -25.2))
 (:CURVE-TO (31.6 -3.5) (3.8 -32.6) (3.8 -32.6)))
|#
        (P (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")))
    #|
((:MOVE-TO (50.7 2.0))
 (:LINE-TO (62.7 -53.9))
 (:CURVE-TO (62.7 -53.9) (90.3 -33.8) (84.6 -20.4))
 (:CURVE-TO (76.8 -2.3) (57.9 -27.5) (57.9 -27.5)))
|#
    (color-rgb 0 0 0)
    (draw-path L 7)
    (draw-path I 7)
    (draw-path S 7)
    (draw-path P 7))
  (let ((flagpole (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")))
    #|
((:MOVE-TO (-60.6 -120.9))
 (:CURVE-TO (-56.3 -119.6) (-53.4 -115.3) (-55.7 -107.3))
 (:LINE-TO (-122.1 112.4))
 (:CURVE-TO (-124.5 120.4) (-127.9 122.0) (-132.2 120.7))
 (:CURVE-TO (-136.6 119.4) (-140.2 115.8) (-137.8 107.7))
 (:LINE-TO (-71.4 -111.9))
 (:CURVE-TO (-69.0 -120.0) (-65.0 -122.2) (-60.6 -120.9)))
|#
    (color-rgb #xe0 #x77 #x3e)
    (fill-path flagpole)
    (color-rgb 0 0 0)
    (draw-path flagpole 4))
  (gl:end-list))

(defparameter *angle* 0)

(defun draw-objects ()
  "Draw the Lisp logo."
  (gl:with-pushed-matrix
    (gl:translate 170.0 280.0 0.0)
    (gl:rotate *angle* 0 0 1)
    (gl:scale 0.4 0.4 0.4)
    (gl:call-list *flag*))
  (gl:with-pushed-matrix
    (gl:translate 500.0 120.0 0.0)
    (gl:rotate *angle* 0 0 1)
    (gl:scale 0.7 0.7 0.7)
    (gl:call-list *flag*))
  (gl:with-pushed-matrix
    (gl:translate 440.0 340.0 0.0)
    (gl:rotate *angle* 0 0 1)
    (gl:call-list *flag*))
  (gl:with-pushed-matrix
    (gl:translate 200.0 170.0 0.0)
    (gl:rotate *angle* 0 0 1)
    (gl:scale 1.2 1.2 1.2)
    (gl:call-list *flag*)))

(defun draw-screen ()
  "Clear screen and draw multiple Lisp logos."
  (gl:clear-color 1.0 1.0 1.0 0.0)
  (gl:clear :color-buffer-bit :depth-buffer-bit)
  (gl:with-primitives :quads
    (gl:color #xff #xff #xff)
    (gl:vertex 0 0)
    (gl:vertex *screen-width* 0)
    (color-rgb #x69 #xda #x74)
    (gl:vertex *screen-width* *screen-height*)
    (gl:vertex 0 *screen-height*))
  (draw-objects)
  (sdl::SDL_GL_SwapBuffers))

(defun setup-opengl (width height)
  "Setup common OpenGL states."
  (gl:viewport 0 0 width height)
  (gl:matrix-mode :projection)
  (gl:load-identity)
  (gl:ortho 0.0 width height 0 0 1)
  (gl:enable :blend)
  (gl:shade-model :smooth)
  (gl:blend-func :src-alpha :one-minus-src-alpha))

(defun idle ()
  (incf *angle* 2))

(defun run ()
  "Start the application."
  (format t "screen: ~ax~a~%" *screen-width* *screen-height*)
  (sdl::with-init ()
    (sdl::set-window *screen-width* *screen-height* :flags sdl::SDL_OPENGL)
    (sdl::SDL_WM_SetCaption "OpenGL 2D" "OpenGL 2D")
    (setup-opengl *screen-width* *screen-height*)
    (create-flag)
    (sdl::with-events
      (:quit t)
      (:keydown (state scancode key mod unicode)
       (if (sdl::is-key key :SDLK_ESCAPE)
           (sdl::push-quitevent)))
      (:idle             
       (draw-screen)
       (idle)))))