;;;; 3viewer.scm
;
; TODO
;
; * add fade effect for toggling table
; * fade out messages
; * message position incorrect
; * view rotation incorrect or broken


(require-library srfi-4) ; so we have srfi-4 read-syntax and can load it into csi


(module 3viewer (add-effect
		 remove-effect
		 remove-all-effects
		 current-world-transformation
		 add-object
		 remove-object
		 remove-all-objects
		 number-of-objects
		 object-id
		 object-name
		 object-property
		 object-highlighted?
		 update-object
		 update-all-objects
		 all-objects
		 start-viewer
		 current-table
		 current-keymap
		 default-keymap
		 make-keymap
		 join-keymaps
		 keymap?
		 keymap-set!
		 keymap-ref
		 current-refresh-delay
		 resize-window
		 message
		 animation
		 current-radius
		 rotate-view
		 current-view-transformation)

(import scheme chicken)
(use gl glu glut defstruct matchable miscmacros
     srfi-18 srfi-4 data-structures srfi-1 extras)


;;; Window parameters:

(define window-size '(0 . 0))


;;; Lighting

(define light-diffuse '#f32(1 1 1 1))
(define light-position '#f32(1 5 1 0))


;;; Text and table display

(define-constant +char-pixels+ 10)
(define-constant +message-scale+ 0.5)
(define-constant +line-height+ 25)
(define-constant +line-adjustment+ 8)

(define +char-width-scale+
  (/ +char-pixels+ (glut:StrokeWidth glut:STROKE_MONO_ROMAN #\A)))

(define current-table (make-parameter '()))
(define table-visible #t)

(define (draw-text x y text)
  (gl:MatrixMode gl:MODELVIEW)
  (gl:PushMatrix)
  (gl:LoadIdentity)
  (gl:Translatef x (+ y +line-adjustment+) 0)
  (gl:Scalef +char-width-scale+ +char-width-scale+ 1)
  (for-each
   (cut glut:StrokeCharacter glut:STROKE_MONO_ROMAN <>)
   (string->list text))
  (gl:PopMatrix))

(define (draw-line x1 y1 x2 y2)
  (gl:MatrixMode gl:MODELVIEW)
  (gl:PushMatrix)
  (gl:LoadIdentity)
  (gl:Begin gl:LINES)
  (gl:Vertex2f x1 y1)
  (gl:Vertex2f x2 y2)
  (gl:End)
  (gl:PopMatrix))

(define (draw-box x y w h)
  (draw-line x y (+ x w) y)
  (draw-line (+ x w) y (+ x w) (+ y h))
  (draw-line (+ x w) (+ y h) x (+ y h))
  (draw-line x (+ y h) x y))

(define (draw-table)
  (gl:Color3f 1 1 1)
  (and-let* ((data (current-table))
	     (table-visible))
    (let* ((rows (length data))
	   (maxwidth1 8)
	   (maxwidth2 8)
	   (lines
	    (map
	     (match-lambda 
	       ((x . y)
		(let ((xs (->string x))
		      (ys (->string y)))
		  (set! maxwidth1 (max maxwidth1 (string-length xs)))
		  (set! maxwidth2 (max maxwidth2 (string-length ys)))
		  (cons xs ys)))
	       (#f #f))
	     data))
	   (width1 (* +char-pixels+ maxwidth1))
	   (width2 (* +char-pixels+ maxwidth2))
	   (width (+ width1 width2))
	   (x1 (- (car window-size) width))
	   (x2 (- (car window-size) width2))
	   (y (- (cdr window-size) +line-height+)))
      (for-each
       (match-lambda
	 ((xs . ys)
	  (draw-box x1 y width1 +line-height+)
	  (draw-box x2 y width2 +line-height+)
	  (draw-text x1 y xs)
	  (draw-text x2 y ys)
	  (set! y (- y +line-height+)))
	 (#f (set! y (- y +line-height+))))
       lines))) )

(define-constant +initial-message-counter+ 200)

(define current-message #f)
(define message-counter 0)
(define message-color '#f32(1 1 1 1))

(define (message text)
  (set! current-message text) 
  (set! message-counter +initial-message-counter+)
  (f32vector-set! message-color 3 1))

(define (draw-message)
  (when current-message
    (gl:MatrixMode gl:MODELVIEW)
    (gl:PushMatrix)
    (gl:LoadIdentity)
    (f32vector-set! message-color 3 (/ message-counter +initial-message-counter+))
    (gl:Color4fv message-color)
    (let* ((text (string->list current-message))
	   (w (fold 
	       (lambda (c n) (+ (glut:StrokeWidth glut:STROKE_ROMAN c) n))
	       0
	       text)))
      (gl:Translatef
       (/ (- (car window-size) (* +message-scale+ w)) 2)
       (/ (cdr window-size) 2)
       0)
      (gl:Scalef +message-scale+ +message-scale+ 1)
      (for-each
       (cut glut:StrokeCharacter glut:STROKE_ROMAN <>)
       text)
      (gl:PopMatrix)
      (dec! message-counter)
      (when (zero? message-counter)
	(set! current-message #f)))))


;;; effects

(define effects '())

(define (add-effect thunk #!optional name)
  (when name (remove-effect name))
  (push! (cons name thunk) effects))

(define (remove-effect name)
  (set! effects (remove (lambda (e) (eq? name (car e))) effects)))

(define (remove-all-effects)
  (set! effects '()))

(define (apply-effects)
  ;; this is so complicated because `effects' might me modified
  (do ((eff effects (cdr eff))
       (last #f eff))
      ((or (null? effects) (null? eff)))
    (unless ((cdar eff))
      (if last
	  (set-cdr! last (cdr eff))
	  (unless (null? effects)		; this effect removed all others
	    (set! effects (cdr eff)))))))


;;; Animations

(define previous-animation 'spin)
(define animation (make-parameter #f))

(define (do-animation)
  (case (animation)
    ((spin)
     (rotate-view 0.1 0))))

(define (toggle-animation)
  (cond ((animation) =>
	 (lambda (prev)
	   (set! previous-animation prev)
	   (animation #f)))
	(else (animation previous-animation))))


;;; Keyboard input

(defstruct keymap
  (keys '())				; ((KEY . PROC) ...)
  (default #f)				; PROC | #f
  (next #f))				; KEYMAP | #f

(define make-keymap
  (let ((make-keymap make-keymap))
    (lambda args
      (let loop ((args args) (keys '()))
	(cond ((null? args) (make-keymap keys: (reverse keys)))
	      ((null? (cdr args))
	       (make-keymap
		keys: (reverse keys)
		default:
		(ensure procedure? (car args) 'make-keymap 
			"expected default-handler procedure but got" (car args))))
	      (else
	       (loop 
		(cddr args)
		(alist-cons 
		 (car args) 
		 (ensure procedure? (cadr args)
			 'make-keymap
			 "expected key-handler procedure but got" (cadr args))
		 keys))))))))

(define default-keymap 
  (make-keymap
   #\esc (lambda _ (exit))
   #\t (lambda _ (set! table-visible (not table-visible)) #t)
   'up (lambda _ (rotate-view 0 -5))
   'down (lambda _ (rotate-view 0 5))
   'left (lambda _ (rotate-view 5 0))
   'right (lambda _ (rotate-view -5 0))
   'page-up (lambda _ (current-radius (- (current-radius) 1)))
   'page-down (lambda _ (current-radius (+ (current-radius) 1)))
   #\space (lambda _ (toggle-animation))
   (lambda (k) (print k) #t)))

(define (join-keymaps km1 . kms)
  (let loop ((kms (cons km1 kms)))
    (if (null? kms)
	#f
	(let ((km (car kms)))
	  (update-keymap
	   km
	   next: (loop (cdr kms)))))))

(define (keymap-ref km k)
  (alist-ref (keymap-keys km) k equal?))

(define (keymap-set! km k proc)
  (keymap-keys-set!
   km
   (alist-update! k proc (keymap-keys km) equal?)))

(define current-keymap (make-parameter default-keymap))

(define (translate-keyboard-input k)
  (let* ((mod (glut:GetModifiers))
	 (ml (append
	      (if (not (zero? (bitwise-and glut:ACTIVE_ALT mod)))
		  '(alt)
		  '())
	      (if (not (zero? (bitwise-and glut:ACTIVE_CTRL mod)))
		  '(control)
		  '())
	      (if (not (zero? (bitwise-and glut:ACTIVE_SHIFT mod)))
		  '(shift)
		  '()))))
    (if (null? ml)
	k
	(append ml (list k)))))

(define (key k x y)
  (process-key (translate-keyboard-input k)))

(define special-key
  (let ((tab `((,glut:KEY_F1 . f1)
	       (,glut:KEY_F2 . f2)
	       (,glut:KEY_F3 . f3)
	       (,glut:KEY_F4 . f4)
	       (,glut:KEY_F5 . f5)
	       (,glut:KEY_F6 . f6)
	       (,glut:KEY_F7 . f7)
	       (,glut:KEY_F8 . f8)
	       (,glut:KEY_F9 . f9)
	       (,glut:KEY_F10 . f10)
	       (,glut:KEY_F11 . f11)
	       (,glut:KEY_F12 . f12)
	       (,glut:KEY_LEFT . left)
	       (,glut:KEY_UP . up)
	       (,glut:KEY_RIGHT . right)
	       (,glut:KEY_DOWN . down)
	       (,glut:KEY_PAGE_DOWN . page-down)
	       (,glut:KEY_PAGE_UP . page-up)
	       (,glut:KEY_HOME . home)
	       (,glut:KEY_END . end)
	       (,glut:KEY_INSERT . insert))))
    (lambda (k x y)
      (and-let* ((a (assq k tab)))
	(process-key (cdr a))))))

(define (process-key k)
  (let loop ((km (current-keymap)))
    (or (and-let* ((h (assoc k (keymap-keys km))))
	  ((cdr h) k)
	  #t)
	(and-let* ((def (keymap-default km)))
	  (def k))
	(and-let* ((next (keymap-next km)))
	  (loop next)))))


;;; Rendering objects

(defstruct object
  id					; INTEGER
  name
  properties				; ((SYMBOL1 . VALUE1) ...)
  display-list				; INTEGER | #f
  render				; #f | ID -> _
  (select default-select)		; ID -> _
  highlighted? 				; BOOL
  animate				; ID -> BOOL
  needs-update?)			; BOOL

(define-constant +max-objects+ 1000)

(define objects (make-vector +max-objects+ #f))
(define object-counter 0)
(define object-freelist '())

(define-syntax wrap
  (syntax-rules ()
    ((_ getter)
     (define getter
       (let ((getter getter))
	 (lambda (id . args)
	   (apply getter (vector-ref objects id) args)))))))

(wrap object-name)
(wrap object-highlighted?)

(define object-property
  (getter-with-setter
   (lambda (id prop)
     (alist-ref prop (object-properties (vector-ref objects id))))
   (lambda (id prop val)
     (let ((o (vector-ref objects id)))
       (object-properties-set! o (alist-update! prop val (object-properties o)))))))

(define (all-objects)
  (let loop ((i 0) (os '()))
    (cond ((>= i object-counter) (reverse os))
	  ((vector-ref objects i) =>
	   (lambda (o) (loop (fx+ i 1) (cons o os))))
	  (else (loop (fx+ i 1) os)))))

(define (number-of-objects)
  (- object-counter (length object-freelist)))

(define (add-object rproc . args)
  (let ((o (apply make-object render: rproc args)))
    (match object-freelist
      ((index . more)
       (set! object-freelist more)
       (object-id-set! o index)
       (vector-set! objects index o))
      (_ (vector-set! objects object-counter o)
	 (object-id-set! o object-counter)
	 (inc! object-counter)))
    (object-id o)))

(define (remove-object id)
  (let ((o (vector-ref objects id)))
    (when o
      (and-let* ((dl (object-display-list o)))
	(gl:DeleteLists dl 1))
      (vector-set! objects id #f)
      (push! id object-freelist))))

(define current-world-transformation
  (make-parameter void))

(define (remove-all-objects)
  (do ((i 0 (add1 i)))
      ((>= i object-counter))
    (remove-object i))
  (set! object-counter 0)
  (set! object-freelist '()))

(define (update-object id)
  (object-needs-update?-set! (vector-ref objects id) #t))

(define (update-all-objects)
  (do ((i 0 (add1 i)))
      ((>= i object-counter))
    (object-needs-update?-set! (vector-ref objects i) #t)))

(define (draw-objects pick-mode)
  (do ((i 0 (add1 i)))
      ((>= i object-counter))
    (let ((o (vector-ref objects i)))
      (when o
	(let ((id (object-id o))
	      (dl (object-display-list o))
	      (anim (object-animate o)))
	  (when pick-mode
	    (set! anim #f)
	    (gl:LoadName id))
	  (gl:MatrixMode gl:MODELVIEW)
	  (gl:LoadIdentity)
	  ((current-world-transformation))
	  (when anim (set! anim (anim id)))
	  (cond ((or (object-needs-update? o) (not dl) anim)
		 (gl:NewList (add1 id) gl:COMPILE_AND_EXECUTE)
		 ((object-render o) (object-id o))
		 (gl:EndList)
		 (object-display-list-set! o (add1 id))
		 (object-needs-update?-set! o #f))
		(else (gl:CallList dl))))))))

(define (redraw)
  (gl:Clear (bitwise-ior gl:COLOR_BUFFER_BIT gl:DEPTH_BUFFER_BIT))
  (gl:MatrixMode gl:PROJECTION)
  (gl:LoadIdentity)
  (apply-view-transformation)
  (gl:MatrixMode gl:MODELVIEW)
  (gl:LoadIdentity)
  (gl:Enable gl:LIGHT0)
  (gl:Enable gl:LIGHTING)
  (gl:Lightfv gl:LIGHT0 gl:DIFFUSE light-diffuse)
  (gl:Lightfv gl:LIGHT0 gl:POSITION light-position)
  (gl:Enable gl:DEPTH_TEST)
  (draw-objects #f)
  (gl:MatrixMode gl:PROJECTION)
  (gl:LoadIdentity)
  (glu:Ortho2D 0 (car window-size) 0 (cdr window-size))
  (gl:Disable gl:LIGHT0)
  (gl:Disable gl:LIGHTING)
  (gl:Disable gl:DEPTH_TEST)
  (draw-table)
  (draw-message)
  (glut:SwapBuffers))


;;; Selection/highlighting

(define-constant +pick-region+ 10)
(define-constant +select-buffer-size+ 1000)

(define select-buffer (make-u32vector +select-buffer-size+ 0 #t))
(define highlighted-object #f)
  
(define (redraw/select x y proc)
  (gl:Clear (bitwise-ior gl:DEPTH_BUFFER_BIT))
  (gl:MatrixMode gl:PROJECTION)
  (gl:LoadIdentity)
  (let ((vp '#s32(0 0 0 0)))
    (gl:GetIntegerv gl:VIEWPORT vp)
    (glu:PickMatrix x (- (s32vector-ref vp 3) y) +pick-region+ +pick-region+ vp)
    (apply-view-transformation)
    (gl:RenderMode gl:SELECT)
    (gl:InitNames)
    (gl:PushName -1)
    (gl:MatrixMode gl:MODELVIEW)
    (gl:LoadIdentity)
    (gl:Enable gl:DEPTH_TEST)
    (draw-objects #t)
    (let ((hits (gl:RenderMode gl:RENDER)))
      (let loop ((i 0) (hits hits) (best #f) (bestdepth +inf.0))
	(cond ((and (positive? hits) (< i +select-buffer-size+))
	       (let ((n (u32vector-ref select-buffer i))
		     (mindepth (u32vector-ref select-buffer (+ i 1))))
		 (assert (= n 1))
		 (if (< mindepth bestdepth)
		     (loop 
		      (+ i 4)
		      (sub1 hits)
		      (u32vector-ref select-buffer (+ i 3))
		      mindepth)
		     (loop (+ i 4) (sub1 hits) best bestdepth))))
	      ((not best) (unhighlight))
	      (else ((proc (vector-ref objects best)) best)))))))

(define (unhighlight)
  (when highlighted-object
    (object-highlighted?-set! highlighted-object #f)
    (object-needs-update?-set! highlighted-object #t))
  (set! highlighted-object #f))

(define ((highlight o) id)
  (unhighlight)
  (set! highlighted-object o)
  (object-highlighted?-set! o #t)
  (object-needs-update?-set! o #t))

(define (default-select id)
  (let ((name (object-name id)))
    (display id)
    (when name (printf " (~a)" name))
    (newline)))


;;; View transformation

(define current-view-transformation 
  (make-parameter 
   (f64vector 1 0 0 0 0 1 0 0 0 0 1 0 0 0 0 1)))

(define current-radius (make-parameter 5))

(define (apply-view-transformation)
  (glu:Perspective 40 (/ (car window-size) (cdr window-size)) 0.01 100)
  (let* ((eye (f64vector 0 0 (current-radius)))
	 (up '#f64(0 1 0))
	 (trans (current-view-transformation))
	 (eye2 (vector*matrix eye trans))
	 (up2 (vector*matrix up trans)))
    (glu:LookAt
     (f64vector-ref eye2 0)
     (f64vector-ref eye2 1)
     (f64vector-ref eye2 2)
     0 0 0
     (f64vector-ref up2 0)
     (f64vector-ref up2 1)
     (f64vector-ref up2 2))))

(define (vector*matrix v m)
  (f64vector
   (+ (fp* (f64vector-ref v 0) (f64vector-ref m 0)) ; column-major order
      (fp* (f64vector-ref v 1) (f64vector-ref m 4))
      (fp* (f64vector-ref v 2) (f64vector-ref m 8)))
   (+ (fp* (f64vector-ref v 0) (f64vector-ref m 1))
      (fp* (f64vector-ref v 1) (f64vector-ref m 5))
      (fp* (f64vector-ref v 2) (f64vector-ref m 9)))
   (+ (fp* (f64vector-ref v 0) (f64vector-ref m 2))
      (fp* (f64vector-ref v 1) (f64vector-ref m 6))
      (fp* (f64vector-ref v 2) (f64vector-ref m 10)))))

(define (rotate-matrix m axis a)
  (gl:MatrixMode gl:PROJECTION)		; changes mode
  (gl:PushMatrix)
  (gl:LoadMatrixd m)
  (gl:Rotatef 
   a 
   (f32vector-ref axis 0)
   (f32vector-ref axis 1)
   (f32vector-ref axis 2))
  (let ((m (make-f64vector 16)))
    (gl:GetDoublev gl:PROJECTION_MATRIX m)
    (gl:PopMatrix)
    m))

(define (rotate-view xd yd)
  (let ((xm (> (abs xd) (abs yd))))
    (current-view-transformation
     (rotate-matrix
      (current-view-transformation)
      (if xm
	  '#f32(0 1 0)
	  '#f32(1 0 0))
      (if xm (- xd) (- yd))))))


;;; Mouse

(define rotation-start #f)
(define zoom-start #f)

(define (mouse b s x y)
  (cond ((and (= b glut:LEFT_BUTTON) (= s glut:DOWN))
	 (redraw/select x y object-select))
	((= b glut:MIDDLE_BUTTON)
	 (set! rotation-start (and (= s glut:DOWN) (cons x y))))
	((= b glut:RIGHT_BUTTON)
	 (set! zoom-start (and (= s glut:DOWN) y)))))

(define (motion x y)
  (redraw/select x y highlight))

(define (viewmotion x y)
  (cond (rotation-start 
	 (rotate-view
	  (* 0.5 (- x (car rotation-start)))
	  (* 0.5 (- y (cdr rotation-start))))
	 (set! rotation-start (cons x y)))
	(zoom-start 
	 (current-radius
	  (max 0 (+ (current-radius) (* 0.05 (- y zoom-start)))))
	 (set! zoom-start y))))


;;; Idle/refresh

(define current-refresh-delay
  (make-parameter 0.01))

(define (idle)
  (do-animation)
  (apply-effects)
  (thread-sleep! (current-refresh-delay))
  (glut:PostRedisplay))

(define (visible vis)
  (if (= vis glut:VISIBLE)
      (glut:IdleFunc idle)
      (glut:IdleFunc #f)))


;;; Window:

(define (resize w h)
  (set! window-size (cons w h))
  (gl:Viewport 0 0 w h))

(define resize-window glut:ReshapeWindow)

(define (start-viewer #!key (w 800) (h 600) (title "3viewer") (init void))
  (glut:InitDisplayMode (bitwise-ior glut:DOUBLE glut:RGBA glut:DEPTH))
  (glut:InitWindowSize w h)
  (glut:CreateWindow title)
  (glut:DisplayFunc redraw)
  (glut:VisibilityFunc visible)
  (gl:Enable gl:DEPTH_TEST)
  (gl:Enable gl:CULL_FACE)
  (gl:Enable gl:LINE_SMOOTH)
  (gl:Enable gl:BLEND)
  (gl:BlendFunc gl:SRC_ALPHA gl:ONE_MINUS_SRC_ALPHA)
  (gl:SelectBuffer +select-buffer-size+ select-buffer)
  (gl:LineWidth 1.0)
  (glut:KeyboardFunc key)
  (glut:SpecialFunc special-key)
  (glut:MouseFunc mouse)
  (glut:MotionFunc viewmotion)
  (glut:PassiveMotionFunc motion)
  (glut:ReshapeFunc resize)
  (init)
  (glut:MainLoop))

)