; This program displays a hershey vector font file.
; For example: hersh.oc1, hersh.oc2, hersh.oc3, hersh.oc4
;
; Left mouse button -> select next character
; Right mouse button -> select previous character

(require (lib "mred.ss" "mred")
         (lib "class.ss")
         (lib "gl.ss" "sgl")
         (lib "gl-vectors.ss" "sgl")
         (lib "defmacro.ss")
)

; ----- misc -----

(define (real->int val)
  (inexact->exact (round val))
)


(define (assoc-set! alist id new)
  (let ((nlist '()))
    (if (assoc id alist)
      ; in the assoc list
      (begin
        (for-each
          (lambda (x)
            (if (equal? (car x) id)
              (set! nlist (cons (cons (car x) new) nlist))
              (set! nlist (cons x nlist))
            )
          )
          alist
        )
        (reverse! nlist)
      )
      ; new element
      (cons (cons id new) alist)
    )
  )
)

; ----- OpenGL interface -----

(define sx-enable-bit    gl_enable_bit)
(define sx-viewport-bit  gl_viewport_bit)
(define sx-transform-bit gl_transform_bit)
(define sx-lighting-bit  gl_lighting_bit)
(define sx-color-buffer-bit gl_color_buffer_bit)
(define sx-depth-buffer-bit gl_depth_buffer_bit)

(define sx-quad-strip gl_quad_strip)
(define sx-polygon    gl_polygon)
(define sx-line-loop  gl_line_loop)
(define sx-line-strip  gl_line_strip)

(define sx-lighting   gl_lighting)
(define sx-fog        gl_fog)
(define sx-texture-2d gl_texture_2d)
(define sx-depth-test gl_depth_test)
(define sx-cull-face  gl_cull_face)
(define sx-projection gl_projection)
(define sx-modelview  gl_modelview)
(define sx-smooth     gl_smooth)
(define sx-flat       gl_flat)

(define (sx-disable value)
  (glDisable value)
)
(define (sx-enable value)
  (glEnable value)
)
(define (sx-push-attrib lst)
  (for-each (lambda (elem) (glPushAttrib elem)) lst)
)
(define (sx-matrix-mode value)
  (glMatrixMode value)
)
(define sx-push-matrix   glPushMatrix)
(define sx-pop-matrix    glPopMatrix)
(define sx-load-identity glLoadIdentity)
(define sx-pop-attrib    glPopAttrib)
(define (sx-viewport minx miny w h)
  (glViewport minx miny w h)
)
(define (sx-ortho l r t b c f)
  (glOrtho l r t b c f)
)

(define sx-flush         glFlush)

(define sx-end           glEnd)

(define (sx-begin value)
  (glBegin value)
)

(define (sx-vertex2i x y)
  (glVertex2i x y)
)

(define (sx-color4f r g b a)
  (glColor4f r g b a)
)

(define (sx-color4fv lst)
  (apply glColor4f lst)
)

(define (sx-recti minx miny w h)
  (glRecti minx miny w h)
)

(define (sx-clear-color r g b a)
  (glClearColor r g b a)
)

(define (sx-clear lst)
  (for-each (lambda (elem) (glClear elem)) lst)
)

; ----- End of OpenGL interface -----

(define (sx-get-window-width)
  (let* 
    ( (size (sx-get-window-size)) )
    (car size)
  )
)

(define (sx-get-window-height)
  (let*
    ( (size (sx-get-window-size)) )
    (cadr size)
  )
)


(define (sx-configure)
  #t
)

; store the state of the OpenGL 
(define (sx-set-opengl-state )
  (let*
    ( (w (sx-get-window-width))
      (h (sx-get-window-height))
    )
    (sx-push-attrib (list sx-enable-bit 
                          sx-viewport-bit  
                          sx-transform-bit 
                          sx-lighting-bit))

    (sx-disable sx-lighting)
    (sx-disable sx-fog)
    (sx-disable sx-texture-2d)
    (sx-disable sx-depth-test)
    (sx-disable sx-cull-face)

    (sx-viewport 0 0 w h)

    (sx-matrix-mode sx-projection)
    (sx-push-matrix)
    (sx-load-identity)

    (sx-ortho 0 w 0 h -1 1)

    (sx-matrix-mode sx-modelview)
    (sx-push-matrix)
    (sx-load-identity)
  )
)

; restore the state of the OpenGL 
(define (sx-restore-opengl-state)
  (sx-matrix-mode sx-projection)
  (sx-pop-matrix)
  (sx-matrix-mode sx-modelview)
  (sx-pop-matrix)

  (sx-pop-attrib)
)

; redraw the OpenGL window
(define (sx-display)
  (sx-set-opengl-state )

  (let*
    ( (character (substring (list-ref character-list character-index) 2))
      (np        (/ (string-length character) 2))
      (r         (char->integer #\R))
      (cx #f) (cy #f) (x #f) (y #f)
      (w (sx-get-window-width))
      (h (sx-get-window-height))
      (scale 2.0)
    )
    ;(display "\nCharacter index: ")(display character-index)
    ;(display "\nCharacter: ")(display character)(newline)
    (sx-begin sx-line-strip)
    (do ((i 0 (+ i 1))) ((= i np))
      (set! cx (string-ref character (+ (* i 2) 0)))
      (set! cy (string-ref character (+ (* i 2) 1)))
      (if (and (char=? cx #\space)
               (char=? cy #\R))
        (begin
          (sx-end)
          (sx-begin sx-line-strip)
        )
        (begin
          (set! x (- (char->integer cx) r))
          (set! y (- (char->integer cy) r))
          (set! x (real->int (+ (* x scale) (* w 0.5))))
          (set! y (real->int (+ (* y scale) (* h 0.5))))
          (sx-vertex2i x (- h y))
        )
      )
    )
    (sx-end)
  )

  (sx-flush)

  (sx-restore-opengl-state)
)


; it must return #t for redisplay or #f for no redisplay
(define (sx-mouse button state x y)
  (if (and (eq? button 'left) (eq? state 'up))
    (begin
      (set! character-index (+ character-index 1))
      (if (= character-index (length character-list))
        (set! character-index 0)
      )
      #t
    )
    (if (and (eq? button 'right) (eq? state 'up))
      (begin
        (set! character-index (- character-index 1))
        (if (= character-index -1)
          (set! character-index (- (length character-list) 1))
        )
        #t
      )
      #f
    )
  )
)



; ----------------------------------------------------------------------

; ----- scheme and window environment dependent part -----
; this is the part which should be defined for any scheme environment

(define *GL_VIEWPORT_WIDTH*  #f)
(define *GL_VIEWPORT_HEIGHT* #f)

(define (sx-get-window-size)
  (list *GL_VIEWPORT_WIDTH* *GL_VIEWPORT_HEIGHT*)
)

(define sx-canvas%
  (class* canvas% ()
    (inherit with-gl-context swap-gl-buffers)

    (define/override (on-paint)
      (with-gl-context
        (lambda ()
          (sx-clear-color 0.0 0.0 0.0 0.0)
          (sx-clear (list sx-color-buffer-bit sx-depth-buffer-bit))

          (sx-display)
          (swap-gl-buffers)
        )
      )
    )

    (define/override (on-size width height)
      (with-gl-context
        (lambda ()
          (set! *GL_VIEWPORT_WIDTH* width)
          (set! *GL_VIEWPORT_HEIGHT* height)
          (sx-configure)
        )
      )
    )

    (define/override (on-event e)
      (with-gl-context
        (lambda ()
          (let* 
            ( (button #f)
              (state #f)
              (x #f) (y #f)
            )
            (cond
              ; left mouse button down
              ( (send e button-down? 'left)
                (set! button 'left)
                (set! state 'down)
                (set! x (send e get-x))
                (set! y (send e get-y))
              )
              ; right mouse button down
              ( (send e button-down? 'right)
                (set! button 'right)
                (set! state 'down)
                (set! x (send e get-x))
                (set! y (send e get-y))
              )
              ; dragging mouse
              ( (eq? (send e get-event-type) 'motion)
                (set! button #f)
                (set! state 'move)
                (set! x (send e get-x))
                (set! y (send e get-y))
              )
              ; left mouse up
              ( (send e button-up? 'left)
                (set! button 'left)
                (set! state 'up)
                (set! x (send e get-x))
                (set! y (send e get-y))
              )
              ; right mouse up
              ( (send e button-up? 'right)
                (set! button 'right)
                (set! state 'up)
                (set! x (send e get-x))
                (set! y (send e get-y))
              )
            )
            (if (sx-mouse button state x y)
              ; redisplay
              (queue-callback (lambda x (send this on-paint)) #t)
            )
          )
        )
      )
    )

    (super-instantiate () (style '(gl)))
  )
)

(define-macro (while test . body)
  `(do () ((not ,test))
    ,@body
  )
)


(define (throw-char fp)
  (read-char fp)
  (while (member (peek-char fp) (list #\newline #\return))
    (read-char fp)
  )
)
(define character-index 0)
(define character-list '())
(define fp (open-input-file (get-file "Select 'hersh.oc?' file" 
                                      #f #f #f #f null
                                      '(("Any" "*.*")))))
(while (not (equal? (peek-char fp) eof))
  (let*
    ( (id (list->string (list (read-char fp) (read-char fp) (read-char fp) 
                              (read-char fp) (read-char fp))))
      (ns (list->string (list (read-char fp) (read-char fp) (read-char fp))))
      (np (read (open-input-string ns)))
      (c1 #f)
      (c2 #f)
      (line '())
    )
    (do ((i 0 (+ i 1))) ((= i np))
      (if (or (= i 32) (= i 68)
              (= i 104) (= i 140))
        (throw-char fp)
      )
      (set! c1 (read-char fp))
      (set! c2 (read-char fp))

      (set! line (cons c2 (cons c1 line)))
    )
    (throw-char fp)
    (set! line (list->string (reverse line)))
    
    (set! character-list (cons line character-list))
    
  )
)
(close-input-port fp)
(set! character-list (reverse character-list))

; show the window
(let* 
  ((f (make-object frame% "Hershey font" #f))
   (w (instantiate sx-canvas% (f)
                              (min-width  150)
                              (min-height 150)))
  )

  (send f show #t)
)