; FIXME:
; - object rotation axis could be random per type

(module jewel mzscheme

  (require (lib "unit.ss")
	   (lib "string.ss")
           (lib "class.ss")
	   (lib "file.ss")
           (lib "mred.ss" "mred")
           (lib "gl.ss" "sgl")
           (lib "gl-vectors.ss" "sgl")
	   (only (lib "sgl.ss" "sgl") get-gl-version-number)
	   "shapes.scm"
	   "array.scm"
	   "text.scm"
	   "../show-help.ss"
  )

  (provide game-unit)


  (define game-unit
    (unit
      (import)
      (export)

  ; -----------------------------------------------------------------
  ; global constants 
  ; -----------------------------------------------------------------  
  
  ; defines whether animation is frozen
  (define freeze #f)
  ; animation frame time interval
  (define timer-interval 30)

  ; number of points achieved in the game
  (define jewel-score   #f)
  ; game level
  (define jewel-level   #f)
  ; number of available moves 
  (define jewel-nmoves  #f)
  ; stage in the game
  (define jewel-stage   #f)
  ; how quickly life is decreased
  (define jewel-decay   #f)
  ; life points
  (define jewel-life    #f)
  ; difficulty level
  (define jewel-difficulty 0)

  ; table of high scores, loaded from a file
  (define high-scores #( ("NOBODY" "0" "1")
                         ("NOBODY" "0" "1")
                         ("NOBODY" "0" "1") 
                         ("NOBODY" "0" "1")
                         ("NOBODY" "0" "1")
                         ("NOBODY" "0" "1")
                         ("NOBODY" "0" "1")
                         ("NOBODY" "0" "1")
                         ("NOBODY" "0" "1")
                         ("NOBODY" "0" "1")
                      ))
  
  (define startlife    1000.0)
  (define lifevisible  (* startlife 2.0))
  (define credit       10.0)
  (define initialdecay 0.4)
  (define decayadd     0.02)
  (define nextlevel    10)
  (define dist         20)
  
  ; Values can be:
  ; PLAYING, GAME-OVER, DIFFICULTY
  (define gamestate    #f)
  ; Values can be:
  ; ACTION-LOOKING, ACTION-WAITING, 
  ; ACTION-REMOVING, ACTION-DROPPING
  ; ACTION-SWAPPING, ACTION-UNSWAPPING
  (define action-mode  #f)
  ; mouse over this element
  (define cposx        0)
  (define cposy        0)
  ; rate of vanishing and rate of falling
  (define vanishrate   0.05)
  (define fallrate     0.05)
  ; swapping is done in how many steps
  (define swaptime     20)
  ; when mouse button is pressed, this stores the position
  (define down-x       #f)
  (define down-y       #f)
  ; tells whether the mouse button is pressed
  (define isdown?      #f)
  ; has something been selected for swapping
  (define tryswap?     #f)
  (define font-scale   0.09)
  ; for keyboard-based game:
  (define bubble-x     #f)
  (define bubble-y     #f)
  (define revert-bubble-x #f)
  (define revert-bubble-y #f)
  (define locked?      #f)

  (define need-help? #t)
  
  (define white        #(1.0 1.0 1.0 1.0))
  (define white2       #(0.7 0.7 0.7 1.0))
  (define grey         #(0.75 0.75 0.75 1.0))
  (define grey2        #(0.75 0.75 0.75 1.0))
  (define bubble-color #(0.8 0.6 1.0 0.4))
  (define bubble-lock-color #(1.0 1.0 1.0 0.4))
  (define spacing      1.76)
  (define shiftx       3.0)
  (define shifty       0.0)
  (define scorex      -8.0)
  (define scorey       5.5)
  (define scorez       8.0)
  (define linespace    2.5)
  (define ex           8)
  (define ey           8)
  (define objectlists  #f)
  (define lightpos     #(-2.0 4.0 4.0 0.0))
  (define light1pos    #(22.0 2.0 4.0 0.0))
  (define light2pos    #(0.0  0.0 4.0 0.0))
  (define diff-color   0)
  (define diff-shape   0)

  (define color-map #( #(0.2 0.2 1.0 1.0) ; blue
                       #(1.0 0.5 0.0 1.0) ; orange
                       #(1.0 1.0 0.0 1.0) ; yellow
                       #(1.0 0.0 1.0 1.0) ; magenta
                       #(0.0 0.8 0.2 1.0) ; green
                       #(0.8 0.1 0.0 1.0) ; red
                       #(1.0 1.0 1.0 1.0) ; white
                     ))
    
  ; 4 x 4 matrices
  (define unproject_matrix
    '#( #(0.266667  0.0  0.0  0.0)
        #(0.0  0.2  0.0  0.0)
        #(0.0  0.0  -26.881655  30.769228)
        #(0.0  0.0  -0.846154   1.0) )
  )
  ; 4 element vector
  (define viewport #f)
  
  
  ; -----------------------------------------------------------------
  ; Defining window toolkit classes
  ; -----------------------------------------------------------------
  
  ; defines a new main window
  (define jewel-frame%
    (class* frame% ()
    
      (define/augment (on-close)
        (jewel-quit-game)
      )
    
      (define/override (on-subwindow-char window event)
        (let*
          ( (c (send event get-key-code))
	    (needed-help? need-help?))
	  (set! need-help? #f)
          (cond
            ; ESCAPE character exits
            ( (eq? c 'escape)
              (if (not (equal? gamestate 'GAME-OVER))
                (begin
                  (set! freeze #f)
                  (send *TIMER* start timer-interval)
                  (set! gamestate 'GAME-OVER)
                )
                (begin
                  (jewel-quit-game)
                  (send *MAIN_WINDOW* show #f)
                )
              )
            )
            ( (eq? c #\space)
              (if (equal? gamestate 'GAME-OVER)
                (begin
                  (difficulty-ask)
                )
		(jewel-key-lock)
              )
            )
	    ( (or (eq? c #\h) (eq? c #\H))
	      (show-jewel-help) )
            ( (or (eq? c #\p) (eq? c #\P))
              (if (equal? gamestate 'PLAYING)
                (begin
                  (set! freeze (not freeze))
                  (if freeze
                    (send *TIMER* stop)
                    (send *TIMER* start timer-interval)
                  )
                )
              )
            )
            ( (and (equal? gamestate 'DIFFICULTY)
                   (member c '(#\0 #\1 #\2 #\3 #\4))
              )
              (case c
                ( (#\0)
                  (jewel-start-game 0) )
                ( (#\1)
                  (jewel-start-game 1) )
                ( (#\2)
                  (jewel-start-game 2) )
                ( (#\3)
                  (jewel-start-game 3) )
                ( (#\4)
                  (jewel-start-game 4) )
              )
            )

	    (else
	     (case c
	       [(up) (jewel-key-move 0 -1)]
	       [(down) (jewel-key-move 0 +1)]
	       [(left) (jewel-key-move -1 0)]
	       [(right) (jewel-key-move +1 0)]
	       [(release) (set! need-help? needed-help?)]
	       [else (set! need-help? #t)]))
          )
        )
      )
    
      (super-instantiate () )
    )
  )
  
  
  ; defines a new OpenGL canvas, handling mouse and rendering, etc  
  (define jewel-canvas%
    (class* canvas% ()
      (inherit with-gl-context swap-gl-buffers)

      (define initialised #f)

      (init-field (expose #f)
                  (realize #f)
                  (configure     #f)
                  (mouse-press   #f)
                  (mouse-motion  #f)
                  (mouse-release #f)
      )
    
      (define/override (on-event e)
        (with-gl-context
          (lambda ()
            (cond
              ; mouse down
              ( (send e button-down? 'right)
                (mouse-press 'right (send e get-x) (send e get-y))
              )
              ( (send e button-down? 'middle)
                (mouse-press 'middle (send e get-x) (send e get-y))
              )
              ( (send e button-down? 'left)
                (mouse-press 'left (send e get-x) (send e get-y))
              )
              ; mouse up
              ( (send e button-up? 'right)
                (mouse-release 'right (send e get-x) (send e get-y))
              )
              ( (send e button-up? 'middle)
                (mouse-release 'middle (send e get-x) (send e get-y))
              )
              ( (send e button-up? 'left)
                (mouse-release 'left (send e get-x) (send e get-y))
              )
              ; mouse motion
              ( (eq? (send e get-event-type) 'motion)
                (mouse-motion (send e get-x) (send e get-y))
              )
            )
          )
        )
      )
	      

      (define/override (on-paint)
        (with-gl-context
          (lambda ()
            (if (and initialised expose)
              (expose)
            )
            (swap-gl-buffers)
          )
        )
      )

      (define/override (on-size width height)
        (with-gl-context
          (lambda ()
            (if (not initialised)
              (begin
                (realize)
                (set! initialised #t)
              )
            )
            (configure width height)
          )
        )
      )

      (let ([cfg (new gl-config%)])
	(send cfg set-multisample-size 4)
	(send cfg set-stencil-size 1)
	(super-new (style '(no-autoclear)) (gl-config cfg)))

      (inherit get-dc)
      (unless (send (get-dc) get-gl-context)
	(message-box "Error"
		     (string-append "Jewel requires OpenGL, but there was an error initializing"
				    " the OpenGL context. Probably OpenGL is not supported by" 
				    " the current display, or it was disabled when PLT Scheme was"
				    " configured and compiled.")
		     #f
		     '(ok stop))
	(exit))

    )
  )

  
  ; -----------------------------------------------------------------
  ; element handling functions
  ; -----------------------------------------------------------------
  (define element-db #f)
  (define move-db #f)

  ; initialise one element
  (define (element-init iy ix)
    (let
      ( (elem (vector-ref (vector-ref element-db iy) ix))
        (move (vector-ref move-db (+ iy 2)))
        (type (random 7))
      )
      (hash-table-put! elem 'type     type )
      (hash-table-put! elem 'angle    (random 360) )
      (hash-table-put! elem 'ax       0.0 )
      (hash-table-put! elem 'ay       1.0 )
      (hash-table-put! elem 'az       0.0 )
      (hash-table-put! elem 'fall     0.0 )
      (hash-table-put! elem 'speed    0.0 )
      (hash-table-put! elem 'vanish   1.0 )
      (hash-table-put! elem 'dx       0.0 )
      (hash-table-put! elem 'dy       0.0 )
      (hash-table-put! elem 'swapping 0 )

      (cond
        ; one color per type
        ; one shape for all type
        ( (= jewel-difficulty 1)
          (hash-table-put! elem 'color type)
          (hash-table-put! elem 'shape diff-shape)
        )
        ; one color for all type
        ; one shape per type
        ( (= jewel-difficulty 2)
          (hash-table-put! elem 'color diff-color)
          (hash-table-put! elem 'shape type)
        )
        ; one color per type
        ; random shape
        ( (= jewel-difficulty 3)
          (hash-table-put! elem 'color type)
          (hash-table-put! elem 'shape (random 7))
        )
        ; random color
        ; one shape per type
        ( (= jewel-difficulty 4)
          (hash-table-put! elem 'color (random 7))
          (hash-table-put! elem 'shape type)
        )
        ; default
        ; one color per type
        ; one shape per type
        ( else
          (hash-table-put! elem 'color type)
          (hash-table-put! elem 'shape type)
        )
      )
      
      ; set the element type in the move database
      (vector-set! move (+ ix 2) type)
    )
  )


  ; initialise the element database, N x N matrix
  (define (element-init-db)
    ; initialise the move database
    (set! move-db (make-vector (+ ey 4) #f))
    (do ((iy 0 (+ iy 1))) ((= iy (+ ey 4)))
      (vector-set! move-db iy (make-vector (+ ex 4) -1))
    )
  
    (set! element-db (make-vector ey #f))
    (do ((iy 0 (+ iy 1))) ((= iy ey))
      (let*
        ( (row (make-vector ex #f)) )
        (vector-set! element-db iy row)
        (do ((ix 0 (+ ix 1))) ((= ix ex))
          (let* 
            ( (elem (make-hash-table 'equal)) )
            (vector-set! row ix elem)
            (element-init iy ix)
          )
        )
      ); end of let
    )
  )
  

  (define (element-get iy ix prop)
    (hash-table-get (vector-ref (vector-ref element-db iy) ix)
                    prop (lambda () #f))
  )


  (define (element-set! iy ix prop value)
    (let*
      ( (elem (vector-ref (vector-ref element-db iy) ix)) )
      (hash-table-put! elem prop value)
    )
  )


  (define (element-swap! iy ix jy jx)
    (let*
      ( (ri (vector-ref element-db iy))
        (rj (vector-ref element-db jy))
        (tt (vector-ref ri ix))
        ; move array
        (mi (vector-ref move-db (+ iy 2)))
        (mj (vector-ref move-db (+ jy 2)))
        (mt (vector-ref mi (+ ix 2)))
      )
      (vector-set! ri ix (vector-ref rj jx))
      (vector-set! rj jx tt)
      ; move array 
      (vector-set! mi (+ ix 2) (vector-ref mj (+ jx 2)))
      (vector-set! mj (+ jx 2) mt)
    )
  )


  ; copy from i to j
  (define (element-copy! iy ix jy jx)
    (let*
      ( (elem1 (vector-ref (vector-ref element-db iy) ix))
        (elem2 (vector-ref (vector-ref element-db jy) jx))
      )
      (hash-table-for-each 
        elem1
        (lambda (key val) (hash-table-put! elem2 key val))
      )
      ; move array
      (array-set! move-db (+ jy 2) (+ jx 2)
                  (array-ref move-db (+ iy 2) (+ ix 2))
      )
    )
  )

  ; -----------------------------------------------------------------
  ; score number handling functions
  ; -----------------------------------------------------------------

  (define score-numbers (make-hash-table 'equal))
  (define score-key     0)
  (define score-fade    0.01)

  (define (score-add x y z fade value)
    (let*
      ( (elem (make-hash-table 'equal)) )
      (hash-table-put! elem 'x x)
      (hash-table-put! elem 'y y)
      (hash-table-put! elem 'z z)
      (hash-table-put! elem 'fade fade)
      (hash-table-put! elem 'value value)
    
      (hash-table-put! score-numbers score-key elem)
      (set! score-key (+ score-key 1))
    )
  )
  
  (define (score-set! elem prop val)
    (hash-table-put! elem prop val)
  )

  (define (score-del! score-key)
    (hash-table-remove! score-numbers score-key)
  )

  (define (score-get elem prop)
    (hash-table-get elem prop)
  )

  (define (score-for-each proc table)
    (hash-table-for-each
      table
      (lambda (key val) (proc key val))
    )
  )

  ; -----------------------------------------------------------------
  ; High score reading, writing and rendering
  ; -----------------------------------------------------------------

  ; split a string line at the ch character(s) into tokens
  ; for example:
  ; "hello ladies and gentleman" -> ("hello" "ladies" "and" "gentleman")
  (define (text-split str ch empty)
    (let* 
      ((idx (string-length str))
       (last #f)
       (slist '())
      )
      (do () ( (not (>= idx 0)) )
        (set! last idx)
        (do () ( (not (and (> idx 0) 
                           (not (char=? (string-ref str (- idx 1)) ch))
                      )
               ) )
          (set! idx (- idx 1))
        )
        (if (>= idx 0)
          (begin
            (if (or empty
                    (and (not empty) (> (- last idx) 0)) )
              (set! slist (cons (substring str idx last) slist))
            )
            (set! idx (- idx 1))
          )
        )
      )
      slist
    )
  )


  (define (high-score-read)
    (let ([l (get-preference 'plt:jewel:scores (lambda () null))])
      (let loop ([l l][i 0])
	(unless (or (not (pair? l))
		    (not (list? (car l)))
		    (not (= (length (car l)) 3))
		    (= i 10))
	  (vector-set! high-scores i (map clean-string (car l)))
	  (loop (cdr l) (+ i 1))))))


  (define (high-score-write)
    (put-preferences '(plt:jewel:scores) (list (vector->list high-scores))))
  
  (define (get-user)
    (let ([s (get-text-from-user "High Score"
				 "High Scorer's Name:"
				 *MAIN_WINDOW*
				 (or (getenv "USER")
				     (getenv "USERNAME")))])
      (if s
	  (clean-string s)
	  "UKNOWN")))

  (define (clean-string s)
    (regexp-replace* #rx"[^-A-Z0-9+]" 
		     (let ([s (string-upcase s)])
		       (substring s 0 (min (string-length s) 10)))
		     " "))

  (define (high-score-set)
    (let*
      ( (score #f)
        (exit? #f)
      )

      (do ((i 0 (+ i 1))) ((or exit? (= i (vector-length high-scores))))
        (set! score (vector-ref high-scores i))
        (if (> jewel-score (string->number (list-ref score 1)))
          (begin
            (do ((j (- (vector-length high-scores) 1) (- j 1)))
                ((= j i))
              (vector-set! high-scores j (vector-ref high-scores (- j 1)))
            )
            (vector-set! high-scores i
                         (list (get-user)
                               (number->string jewel-score)
                               (number->string jewel-level)))
            (set! exit? #t)
          )
        )
      )
    )
  )
  
  
  (define (high-score-render)
    (let*
      ( (highxname  2.5)
        (highxscore 6.0)
        (highxlevel 5.5)
        (score #f)
        (dimmer #(0.0 0.0 0.0 0.5))
        (boxleft  -3.5)
        (boxright  8.2)
        (boxtop    5.7)
        (boxbottom (- boxtop))
        (boxz      8.0)
      )
      (glPushMatrix)
      (glTranslatef -3.0 5.5 8.1)
      (glScalef 0.6 0.6 0.6)
    
      (glPushMatrix)
      (glTranslatef highxname 0.0 0.0)
      (string-draw "NAME")
      (glTranslatef highxscore 0.0 0.0)
      (string-draw "SCORE")
      (glTranslatef highxlevel 0.0 0.0)
      (string-draw "LEVEL")
      (glPopMatrix)
    
      (do ((i 0 (+ i 1))) ((= i (vector-length high-scores)))
        (glTranslatef 0.0 -1.8 0.0)
        (glPushMatrix)
        (set! score (vector-ref high-scores i))
        (string-draw (number->string (+ i 1)) )
        (glTranslatef highxname 0.0 0.0)
        (if (< (string-length (list-ref score 0)) 6)
          (string-draw (list-ref score 0) )
          (string-draw (substring (list-ref score 0) 0 6) )
        )
        (glTranslatef (+ highxscore 1.0) 0.0 0.0)
        (string-draw (list-ref score 1) )
        (glTranslatef highxlevel 0.0 0.0)
        (string-draw (list-ref score 2) )
        (glPopMatrix)
      )
      (glPopMatrix)

      ; draw a dim square over the jewels
      (glEnable GL_BLEND)
      (when (>= (get-gl-version-number) 13)
	(glEnable GL_MULTISAMPLE))
      (glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA)
      (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE 
                    (vector->gl-float-vector dimmer))
      (glDisable GL_LIGHT0)
      (glDisable GL_LIGHT1)
      (glBegin GL_QUADS)
      (glVertex3f boxleft boxtop boxz)
      (glVertex3f boxleft boxbottom boxz)
      (glVertex3f boxright boxbottom boxz)
      (glVertex3f boxright boxtop boxz)
      (glEnd)
      (glEnable GL_LIGHT0)
      (glEnable GL_LIGHT1)
      (glBlendFunc GL_ONE GL_ONE)
      (glDisable GL_BLEND)
    )
  )
  
  
  ; -----------------------------------------------------------------
  ; Difficulty level
  ; -----------------------------------------------------------------
  
  (define (difficulty-ask)
    (set! gamestate 'DIFFICULTY)
  )
  
  (define (difficulty-render)
    (let*
      ( (highxname  2.5)
        (highxscore 6.0)
        (highxlevel 5.5)
        (dimmer     #(0.0 0.0 0.0 0.5))
        (boxleft   -3.5)
        (boxright   8.2)
        (boxtop     5.7)
        (boxbottom  (- boxtop))
        (boxz       8.0)
        (levels     #("BEGINNER"
                      "MATCH EVERYTHING"
                      "EASY"
                      "MATCH COLORS"
                      "MEDIUM"
                      "MATCH SHAPES"
                      "HIGH"
                      "MATCH COLORS"
                      "EXTREME"
                      "MATCH SHAPES"
                     ))
      )
      (glPushMatrix)
      (glTranslatef -3.0 5.5 8.1)
      (glScalef 0.6 0.6 0.6)
    
      (glPushMatrix)
      (glTranslatef highxname 0.0 0.0)
      (string-draw "SELECT DIFFICULTY")
      (glPopMatrix)
    
      (do ((i 0 (+ i 1))) ((= i (vector-length levels)))
        (glTranslatef 0.0 -1.8 0.0)
        (glPushMatrix)
        (if (= (remainder i 2) 0)
          (string-draw (number->string (/ i 2)) )
        )
        (glTranslatef highxname 0.0 0.0)
        (string-draw (vector-ref levels i) )
        (glPopMatrix)
      )
      (glPopMatrix)

      ; draw a dim square over the jewels
      (glEnable GL_BLEND)
      (glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA)
      (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE 
                    (vector->gl-float-vector dimmer))
      (glDisable GL_LIGHT0)
      (glDisable GL_LIGHT1)
      (glBegin GL_QUADS)
      (glVertex3f boxleft boxtop boxz)
      (glVertex3f boxleft boxbottom boxz)
      (glVertex3f boxright boxbottom boxz)
      (glVertex3f boxright boxtop boxz)
      (glEnd)
      (glEnable GL_LIGHT0)
      (glEnable GL_LIGHT1)
      (glBlendFunc GL_ONE GL_ONE)
      (glDisable GL_BLEND)
    )
  )
  
  
  ; -----------------------------------------------------------------
  ; Initialisation
  ; -----------------------------------------------------------------

  (define (jewel-quit-game)
    (send *TIMER* stop)
    (high-score-write)
;    (display "\nTHE END\n")
  )
  
  
  (define (jewel-init-game)
    (element-init-db)
    
    (set! jewel-stage   0)
    (set! jewel-score   0)
    (set! jewel-level   0)
    (set! jewel-nmoves  0)
    (set! score-numbers (make-hash-table 'equal))

    (set! gamestate 'GAME-OVER)
    ;read high scores
    (high-score-read)
  )
  
  
  (define (jewel-start-game diff)
    (set! jewel-difficulty diff)
    (set! jewel-life    startlife)
    (set! jewel-decay   initialdecay)
    (set! jewel-stage   0)
    (set! jewel-score   0)
    (set! jewel-level   0)
    (set! jewel-nmoves  0)

    ; make the current configuration to vanish
    (do ((iy 0 (+ iy 1))) ((= iy ey))
      (do ((ix 0 (+ ix 1))) ((= ix ex))
        (element-set! iy ix 'vanish 0.999)
      )
    )

    (set! diff-color  (random 7))
    (set! diff-shape  (random 7))
    (set! gamestate   'PLAYING)
    (set! action-mode 'ACTION-REMOVING)
  )
  
  
  (define (jewel-realize)
    (let*
      ( ( scale 0.88) )

      (glEnable GL_CULL_FACE)
      (glEnable GL_LIGHTING)
      (glEnable GL_LIGHT0)
      (glEnable GL_LIGHT1)

      (glLightfv GL_LIGHT0 GL_SPECULAR (vector->gl-float-vector white))
      (glLightfv GL_LIGHT0 GL_DIFFUSE  (vector->gl-float-vector grey))

      (glLightfv GL_LIGHT1 GL_SPECULAR (vector->gl-float-vector white2))
      (glLightfv GL_LIGHT1 GL_DIFFUSE  (vector->gl-float-vector grey2))

      (glLightfv GL_LIGHT2 GL_SPECULAR (vector->gl-float-vector white))
      (glLightfv GL_LIGHT2 GL_DIFFUSE  (vector->gl-float-vector grey))

      (glEnable GL_DEPTH_TEST)

      (glShadeModel GL_SMOOTH)
      (glClearColor 0.0 0.0 0.0 1.0)
      (glClear GL_COLOR_BUFFER_BIT)
      (glClear GL_DEPTH_BUFFER_BIT) 

      (glDisable GL_BLEND)
      (glBlendFunc GL_ONE GL_ONE)

      (glLineWidth 2.0)
      (glDisable GL_LINE_SMOOTH)

      ; initialise objects
      (set! objectlists (glGenLists 8))
      (glNewList (+ objectlists 0) GL_COMPILE)
      (makebucky (* scale 0.9))
      (glEndList)

      (glNewList (+ objectlists 1) GL_COMPILE)
      (makebevelcube scale)
      (glEndList)

      (glNewList (+ objectlists 2) GL_COMPILE)
      (makepyramid (* scale 0.7))
      (glEndList)

      (glNewList (+ objectlists 3) GL_COMPILE)
      (makeicosahedron (* scale 0.9))
;      (makespiky (* scale 0.9))
      (glEndList)
  
      (glNewList (+ objectlists 4) GL_COMPILE)
      (makecylinder (* scale 0.9))
      (glEndList)

      (glNewList (+ objectlists 5) GL_COMPILE)
      (makediamond (* scale 0.9))
      (glEndList)

      (glNewList (+ objectlists 6) GL_COMPILE)
      (makeuvsphere (* scale 0.9))
      (glEndList)
    
      (glNewList (+ objectlists 7) GL_COMPILE)
      (makedisc (* scale 1.2))
      (glEndList)
    
      ; initialise fonts
      (string-init font-scale)
    )
  )


  (define (jewel-configure width height)
    (glViewport 0 0 width height)
    (set! viewport (make-vector 4 0))
    (vector-set! viewport 2 width)
    (vector-set! viewport 3 height)
  
    ; projection matrix
    (glMatrixMode GL_PROJECTION)
    (glLoadIdentity)
    (if (< width height)
      (let ( (h (/ height width)) )
        (glFrustum -1.0 1.0 (- h) h 5.0 60.0)
      )
      (let ( (h (/ width height)) )
        (glFrustum (- h) h -1.0 1.0 5.0 60.0)
      )
    )
    ; modelview matrix
    (glMatrixMode GL_MODELVIEW)
    (glLoadIdentity)
    (glTranslatef 0.0 0.0 -40.0)
  )

  ; -----------------------------------------------------------------
  ; Handling animation and game control
  ; -----------------------------------------------------------------

  ; determine which elements to replace
  (define (replace)
    (let*
      ( (falls (make-vector ex 1)) )
    
      (do ((iy (- ey 1) (- iy 1))) ((< iy 0))
        (do ((ix 0 (+ ix 1))) ((= ix ex))
          
          (if (= (element-get iy ix 'vanish) 0.0)
            (let ( (finished -1) )
              (do ((k (- iy 1) (- k 1))) ((or (< k 0) (> finished -1)))
                (if (not (= (element-get k ix 'vanish) 0.0))
                  (set! finished k)
                )
              )
              (if (>= finished 0)
                (begin
                  (element-copy! finished ix iy ix)
                  (element-set! finished ix 'vanish 0.0)
                  (element-set! iy ix 'fall (- iy finished))
                )
                (begin
                  ; initializes new elements
                  (element-init iy ix)
                  (element-set! iy ix 'fall (+ iy (vector-ref falls ix)))
                  (vector-set! falls ix (+ 1 (vector-ref falls ix)))
                )
              )
            )
          ) ; end of if
        
        ) ; end of do
      ) ; end of do
    ) ; end of let
  )

  
  (define (addlife chain len x y)
    (let*
      ( (value (+ chain len))
        (sx (+ (* (+ (- x (/ ex 2.0)) 0.5) spacing) shiftx))
        (sy (+ (* (- (/ ey 2.0) y) spacing) shifty))
        (sz 0.0)
      )
      (score-add sx sy sz 1.0 value)
      (set! jewel-score (+ jewel-score value))
      (set! jewel-stage (+ jewel-stage len))
      (set! jewel-life  (+ jewel-life  (* value credit)))
      (if (>= jewel-stage nextlevel)
        (begin
          (set! jewel-stage (- jewel-stage nextlevel))
          (set! jewel-level (+ jewel-level 1))
          (set! jewel-decay (+ jewel-decay decayadd))
        )
      )
    )
  )


  (define (declife)
    (set! jewel-life (- jewel-life jewel-decay))
    (if (< jewel-life 0.0)
      (let*
        ( (score #f) (exit? #f)
        )
        ; set life points to zero
        (set! jewel-life 0.0)
        ; set high score if any
        (high-score-set)
        ; end of game
        (set! gamestate 'GAME-OVER)
      )
    )
  )
  
  ;check for minimum three adjacent elements
  (define (findwins checking)
    (let*
      ( (hadsome #f) )
      ; check the rows for three identical elements
      (do ((iy 0 (+ iy 1))) ((= iy ey))
        (let*
          ( (identical 1) )
          (do ((ix 1 (+ ix 1))) ((= ix (+ ex 1)))
            ; if in range horizontally and
            ; type of the current and the previous element is equal
            (if (and (< ix ex)
                     (= (element-get iy ix 'type)
                        (element-get iy (- ix 1) 'type)))
              (set! identical (+ identical 1))
              ; else three or more identical has been found in a row
              (if (>= identical 3)
                (begin
                  (set! hadsome #t)
                  (if (not checking)
                    (let*
                      ( (x (- ix 1 (/ identical 2.0)))
                        (y (+ iy 0.5))
                      )
                      (addlife 0 (- identical 1) x y)
                    )
                  )
                  ; set the found elements to vanish
                  (do ((k identical (- k 1))) ((= k 0))
                    (element-set! iy (- ix k) 'vanish 0.999)
                  )
                  (set! identical 1)
                )
                (set! identical 1)
              )
            )
          )
        )
      ) ; end of checking rows
       
      ; checking columns for three identical elements
      (do ((ix 0 (+ ix 1))) ((= ix ex))
        (let*
          ( (identical 1) )
          (do ((iy 1 (+ iy 1))) ((= iy (+ ey 1)))
            ; if in range vertically and
            ; type of the current and the previous element is equal
            (if (and (< iy ey)
                     (= (element-get iy ix 'type)
                        (element-get (- iy 1) ix 'type)))
              (set! identical (+ identical 1))
              ; else three or more identical has been found in a row
              (if (>= identical 3)
                (begin
                  (set! hadsome #t)
                  (if (not checking)
                    (let*
                      ( (x ix)
                        (y (- iy 0.5 (/ identical 2.0)))
                      )
                      (addlife 0 (- identical 1) x y)
                    )
                  )
                  ; set the found elements to vanish
                  (do ((k identical (- k 1))) ((= k 0))
                    (element-set! (- iy k) ix 'vanish 0.999)
                  )
                  (set! identical 1)
                )
                (set! identical 1)
              )
            )
          )
        )
      ) ; end of checking columns

      hadsome
    )
  )

  
  ; possible moves
  (define chkpos
    '#( #(1 -1 0 1)
        #(-1 -1 -1 1)
        #(0 -1 1 1)
        #(0 -2 0 1)

        #(1 1 -1 0)
        #(1 -1 -1 -1)
        #(1 0 -1 1)
        #(2 0 -1 0)
      
        #(-1 1 0 -1)
        #(1 1 1 -1)
        #(0 1 -1 -1)
        #(0 2 0 -1)
      
        #(-1 -1 1 0)
        #(-1 1 1 1)
        #(-1 0 1 -1)
        #(-2 0 1 0)
      )
  )

  ; check whether any move is possible in the game field
  (define (anymove?)
    (let*
      ( (moves 0)
        (type  #f)
      )
    
      ; check for all combination
      (do ((iy 0 (+ iy 1))) ((= iy ey))
        (do ((ix 0 (+ ix 1))) ((= ix ex))
          (if (not (= (element-get iy ix 'type)
                      (array-ref move-db (+ iy 2) (+ ix 2))))
            (begin
              (display "wrong iy: ")(display iy)
              (display " ix: ")(display ix)(newline)
            )
          )
          ; all 16, possible combinations
          (do ((k 0 (+ k 1))) ((= k 16))
            (set! type (array-ref move-db (+ iy 2) (+ ix 2)))
            (if (and (= type (array-ref move-db 
                                        (+ iy 2 (array-ref chkpos k 1))
                                        (+ ix 2 (array-ref chkpos k 0))))
                     (= type (array-ref move-db 
                                        (+ iy 2 (array-ref chkpos k 3))
                                        (+ ix 2 (array-ref chkpos k 2))))
                )
              (begin
                #|
                (display "move ")(display type)(newline)
                (display iy)(display " - ")(display ix)(newline)
                (display (+ iy (array-ref chkpos k 1)))(display " - ")
                  (display (+ ix (array-ref chkpos k 0)))(newline)
                (display (+ iy (array-ref chkpos k 3)))(display " - ")
                  (display (+ ix (array-ref chkpos k 2)))(newline)
                |#
                (set! moves (+ moves 1))
              )
            )
          )
        )
      )

      (set! jewel-nmoves moves)
    
      moves
    )
  )

  
  ; function that is called by the timer
  ; handles the switching between states
  (define (jewel-control-game)
  
    ; continuous rotation of elements
    (do ((iy 0 (+ iy 1))) ((= iy ey))
      (do ((ix 0 (+ ix 1))) ((= ix ex))
        (element-set! iy ix 'angle (+ 3.0 (element-get iy ix 'angle)))
      )
    )
    
     ; fading of score numbers
    (score-for-each 
      (lambda (key elem)
        (let*
          ( (fade (- (score-get elem 'fade) score-fade)) )
          (if (< fade 0.0)
            (score-del! key)
            (score-set! elem 'fade fade)
          )
        )
      )
      score-numbers
    )
    
    (case action-mode
      ( (ACTION-LOOKING)
        (if (equal? gamestate 'PLAYING)
          (if (findwins #f)
            (set! action-mode 'ACTION-REMOVING)
            ; check if any move is possible at all ???
            (begin
              (if (= (anymove?) 0)
                ; set all elements to vanish
                (begin
                  (do ((iy 0 (+ iy 1))) ((= iy ey))
                    (do ((ix 0 (+ ix 1))) ((= ix ex))
                      (element-set! iy ix 'vanish 0.999)
                    )
                  )
                  (set! action-mode 'ACTION-REMOVING)
                )
                ; switch to ACTION-WAITING
                (set! action-mode 'ACTION-WAITING)
              )
            )
          )
        )
      )
      ( (ACTION-WAITING)
        (if (equal? gamestate 'PLAYING)
          (begin
            (declife)
            (if tryswap?
              (set! action-mode 'ACTION-SWAPPING)
            )
          )
        )
      )
      ( (ACTION-SWAPPING ACTION-UNSWAPPING)
        (if (equal? action-mode 'ACTION-UNSWAPPING)
          (declife)
        )
        (set! tryswap? #f)
        (let*
          ( (hadsome 0) (swap #f)
            (ax #f) (ay #f) (bx #f) (by #f)
          )
          (do ((iy 0 (+ iy 1))) ((= iy ey))
            (do ((ix 0 (+ ix 1))) ((= ix ex))
              (set! swap (element-get iy ix 'swapping))
              (if (not (= swap 0))
                (begin
                  (set! hadsome 1)
                  (set! swap (+ swap 1))
                  (if (= swap swaptime)
                    (begin
                      (element-set! iy ix 'swapping 0)
                      (set! hadsome 2)
                      ; for the first time it has no meaning
                      (set! ax bx)
                      (set! ay by)
                      ; it always stores the result in bx by
                      (set! bx ix)
                      (set! by iy)
                    )
                    (element-set! iy ix 'swapping swap)
                  )
                )
              )
            )
          )
        
          (if (= hadsome 2)
            (cond
              ( (findwins #f) 
		(set! locked? #f)
		(set! action-mode 'ACTION-REMOVING) )
              ( (equal? action-mode 'ACTION-SWAPPING)
                ; swap back
                (element-swap! ay ax by bx)
                ; set swapping
                (element-set! ay ax 'swapping 1)
                (element-set! ay ax 'dx (- (element-get ay ax 'dx)))
                (element-set! ay ax 'dy (- (element-get ay ax 'dy)))
                (element-set! by bx 'swapping 1)
                (element-set! by bx 'dx (- (element-get by bx 'dx)))
                (element-set! by bx 'dy (- (element-get by bx 'dy)))
                ; unswapping state
		(when revert-bubble-x
		  (set! bubble-x revert-bubble-x)
		  (set! bubble-y revert-bubble-y))
                (set! action-mode 'ACTION-UNSWAPPING)
              )
              ( else 
		(set! locked? #f)
		(set! action-mode 'ACTION-WAITING) )
            )
          )
        )
      )
      ; remove elements from the scene
      ; after removal switch to dropping
      ( (ACTION-REMOVING)
        (let*
          ( (hadsome 0)
            (vanish #f)
          )
          (do ((iy 0 (+ iy 1))) ((= iy ey))
            (do ((ix 0 (+ ix 1))) ((= ix ex))
              (set! vanish (element-get iy ix 'vanish))
              (if (< vanish 1.0)
                (begin
                  (set! vanish (- vanish vanishrate))
                  (if (< vanish 0.0)
                    (begin
                      (element-set! iy ix 'vanish 0.0)
                      (set! hadsome (+ hadsome 1))
                    )
                    (element-set! iy ix 'vanish vanish)
                  )
                )
              )
            )
          )
          (if (> hadsome 0)
            (begin
              (replace)
              (set! action-mode 'ACTION-DROPPING)
            )
          )
        )
      ) ; end of ACTION-REMOVING
      ; drop in new elements to the scene
      ; after dropping switch to looking
      ( (ACTION-DROPPING)
        (let*
          ( (hadsome 0)
            (fall #f)
            (speed #f)
          )
          (do ((iy 0 (+ iy 1))) ((= iy ey))
            (do ((ix 0 (+ ix 1))) ((= ix ex))
              (set! fall (element-get iy ix 'fall))
              (if (> fall 0.0)
                (begin
                  (set! hadsome (+ hadsome 1))
                  (set! fall (- fall (element-get iy ix 'speed)))
                  (set! speed (element-get iy ix 'speed))
                  (element-set! iy ix 'speed (+ speed fallrate))
                  (if (<= fall 0.0)
                    (begin
                      (element-set! iy ix 'fall 0.0)
                      (element-set! iy ix 'speed 0.0)
                    )
                    (element-set! iy ix 'fall fall)
                  )
                )
              )
            )
          )
          (if (= hadsome 0)
            (set! action-mode 'ACTION-LOOKING)
          )
        ); end of let
      ) ; end of ACTION-DROPPING
    )
    
    ; generate an expose event, redraw the opengl window
    (queue-callback 
      (lambda x (send *OPENGL_WINDOW* on-paint))
      #t
    )
  )


  ; -----------------------------------------------------------------
  ; Rendering functions
  ; -----------------------------------------------------------------

  (define (setmaterial color-vect)
    (glMaterialfv GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE
                  (vector->gl-float-vector color-vect))
    (glMaterialfv GL_FRONT_AND_BACK GL_SPECULAR
                  (vector->gl-float-vector white))
    (glMaterialfv GL_FRONT_AND_BACK GL_SHININESS 
                  (vector->gl-float-vector #(25.0)))
  )


  (define (show-life)
    (let*
      ( (sections 24)
        (section-yellow 4)
        (section-red    1)
        (b (/ (* 3.1415927 2.0) 24))
        (a 0)
        (s #f)
      )
      (glPushMatrix)
      (glTranslatef -6.5 -3.0 5.0)
      (glRotatef 11.0 0.0 1.0 0.0)
      
      ; circle outline
      (setmaterial (vector-ref color-map 0))
      (glNormal3f 0.0 0.0 1.0)
      (glBegin GL_LINE_LOOP)
      (do ((i 0 (+ i 1))) ((= i sections))
        (glVertex3f (* (sin a) 2.0)
                    (* (cos a) 2.0)
                    0.0)
        (set! a (+ a b))
      )
      (glEnd)
      
      ; show triangle fan
      (glBegin GL_TRIANGLE_FAN)
      (glEnable GL_NORMALIZE)
      (glVertex3f 0.0 0.0 3.0)
      (if (< jewel-life lifevisible)
        (let*
          ( (x #f) (y #f) )
          (set! a (/ (* 3.1415927 2.0 jewel-life) lifevisible))
          (set! x (* (sin a) 2.0))
          (set! y (* (cos a) 2.0))
          (glNormal3f x y 0.7)
          (glVertex3f x y 0.0)
          (set! s (floor (/ (* jewel-life sections) lifevisible)))
        )
        (set! s sections)
      )
      ; color of the section
      (cond 
        ( (> s section-yellow)
          ; green
          (setmaterial (vector-ref color-map 4))
        )
        ( (> s section-red)
          ; yellow
          (setmaterial (vector-ref color-map 2))
        )
        ( else
          ; red
          (setmaterial (vector-ref color-map 5))
        )
      )
      (do ((i s (- i 1))) ((< i 0))
        (cond
          ( (= i section-yellow) (setmaterial (vector-ref color-map 2)))
          ( (= i section-red)    (setmaterial (vector-ref color-map 5)))
        )
        (set! a (* (- i 0.5) b))
        (glNormal3f (sin a) (cos a) 0.7)
        (set! a (* i b))
        (glVertex3f (* (sin a) 2.0)
                    (* (cos a) 2.0)
                    0.0)
      )
    
      (glEnd)
      
      (glPopMatrix)
    )
  )
  
  ; main OpenGL rendering, called by expose event
  (define (jewel-redraw)
    (glClear GL_COLOR_BUFFER_BIT)
    (glClear GL_DEPTH_BUFFER_BIT) 
    
    (glLightfv GL_LIGHT0 GL_POSITION (vector->gl-float-vector lightpos))
    (glLightfv GL_LIGHT1 GL_POSITION (vector->gl-float-vector light1pos))
    (glLightfv GL_LIGHT2 GL_POSITION (vector->gl-float-vector light2pos))
    
    (if (equal? gamestate 'PLAYING)
      (show-life)
    )
    
    (glPushMatrix)
    
    (let*
      ( (t spacing)
        (x #f)
        (y (* t (- (/ ey 2.0) 0.5)))
        (xt 0.0) (yt 0.0) (zt 0.0)
        (k  (* ex ey))
        (nx #f) (ny #f) (nz #f)
        (obj #f)
        (ang #f)
        (s #f)
        (counter 0)
		   
      )
    
      (glEnable  GL_BLEND)
      (do ((iy 0 (+ iy 1))) ((= iy ey))
        (set! x (* (- t) (- (/ ex 2.0) 0.5)))
        (do ((ix 0 (+ ix 1))) ((= ix ex))
          (set! nx (+ x shiftx))
          (set! ny y)
          (set! nz (* (- 1.0 (element-get iy ix 'vanish)) 50.0))
          (if (not (= (element-get iy ix 'swapping) 0))
            (begin
              (set! ang (/ (* (element-get iy ix 'swapping) 3.1415927)
                           2.0
                           swaptime))
              (set! s (* t (cos ang)))
              (set! nx (+ nx (* s (element-get iy ix 'dx))))
              (set! ny (+ ny (* s (element-get iy ix 'dy))))
              (set! s (* t (sin (* ang 2.0))))
              (if (= (remainder counter 2) 1)
                (set! s (- s))
              )
              (set! counter (+ counter 1))
              (set! nz (+ nz s))
            )
          )
          (set! ny (+ ny (* (element-get iy ix 'fall) t)))
                
          (glTranslatef (- nx xt) (- ny yt) (- nz zt))
          (set! xt nx)
          (set! yt ny)
          (set! zt nz)
          
          (if (and (equal? gamestate 'PLAYING)
                   (= cposx ix) (= cposy iy))
            (begin
              (glEnable GL_LIGHT2)
            )
          )
          
          (glPushMatrix)
          (glRotatef (element-get iy ix 'angle)
                     (element-get iy ix 'ax)
                     (element-get iy ix 'ay)
                     (element-get iy ix 'az))
          
          (setmaterial (vector-ref color-map (element-get iy ix 'color)))
          (glCallList (+ objectlists (element-get iy ix 'shape)))
          
          (glPopMatrix)

          (if (and (equal? gamestate 'PLAYING)
                   (= cposx ix) (= cposy iy))
            (glDisable GL_LIGHT2)
          )

	  (when (and (equal? gamestate 'PLAYING)
		     (not (memq action-mode '(ACTION-REMOVING ACTION-DROPPING ACTION-LOOKING)))
		     bubble-x bubble-y
		     (= ix bubble-x)
		     (= iy bubble-y))
	    (glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA)
	    (glPushMatrix)
	    (setmaterial (if locked? bubble-lock-color bubble-color))
	    (glCallList (+ objectlists 7))
	    (glPopMatrix)
	    (glBlendFunc GL_ONE GL_ONE))
          
          (set! x (+ x t))
        )
        (set! y (- y t))
      )
    )
    
    (glPopMatrix)
    
    ; draw the flying scores
    (glDisable GL_DEPTH_TEST)
    (score-for-each
      (lambda (key elem)
        (let*
          ( (color (make-vector 4 1.0))
            (fade (score-get elem 'fade))
            (x    (score-get elem 'x))
            (y    (score-get elem 'y))
            (z    (score-get elem 'z))
            (val  (score-get elem 'value))
          )
          (vector-set! color 0 fade)
          (vector-set! color 1 fade)
          (vector-set! color 2 fade)
          (glPushMatrix)
          (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE
                        (vector->gl-float-vector color))
          (glTranslatef x (- y (- 1.0 fade)) z)
          (string-draw (string-append "+" (number->string val)) )
          (glPopMatrix)
        )
      )
      score-numbers
    )
    (glEnable GL_DEPTH_TEST)
    
    ; draw the scores on the left hand side
    (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE
                  (vector->gl-float-vector (vector-ref color-map 5)))
    (glPushMatrix)
    (glTranslatef scorex scorey scorez)
    (glScalef 0.8 0.8 0.8)
    (string-draw "SCORE")
    (glTranslatef 0.0 (- linespace) 0.0)
    (string-draw "LEVEL")
    (glTranslatef 0.0 (- linespace) 0.0)
    (string-draw "MOVES")
    (cond
      ( (equal? gamestate 'GAME-OVER)
        (glTranslatef 0.0 (* -2.5 linespace) 0.0)
        (glScalef 0.6 0.6 0.6)
        (string-draw "GAME OVER")
	(glTranslatef 0.0 (* -1.5 linespace) 0.0)
        (glScalef 0.5 0.5 0.5)
	(glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE
		      (vector->gl-float-vector grey))
        (string-draw "SPACE BAR TO START")
	(glTranslatef 0.0 (* -0.6 linespace) 0.0)
        (string-draw "H FOR HELP")
	(glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE
		      (vector->gl-float-vector (vector-ref color-map 5)))
      )
      ( (and (equal? gamestate 'PLAYING)
	     need-help?)
	(glTranslatef 0.0 (* -3.75 linespace) 0.0)
        (glScalef 0.3 0.3 0.3)
	(glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE
		      (vector->gl-float-vector grey))
        (string-draw "DRAG JEWEL WITH MOUSE OR USE ARROW KEYS AND SPACE BAR   H FOR HELP")
	(glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE
		      (vector->gl-float-vector (vector-ref color-map 5))))
    )
    (glPopMatrix)
    
    (glPushMatrix)
    (glTranslatef scorex
                  (- scorey (* linespace 0.4)) 
                  scorez)
    (glScalef 0.8 0.8 0.8)
    (string-draw (number->string jewel-score) )
    (glTranslatef 0.0 (- linespace) 0.0)
    (string-draw (number->string jewel-level) )
    (glTranslatef 0.0 (- linespace) 0.0)
    (string-draw (number->string jewel-nmoves) )  
    (glPopMatrix)

    (glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE
                  (vector->gl-float-vector (vector-ref color-map 6)))
    ; if not playing cover with dim square
    (if (equal? gamestate 'GAME-OVER)  
      (high-score-render)
    )
  
    (if (equal? gamestate 'DIFFICULTY)
      (difficulty-render)
    )
  )

  ; -----------------------------------------------------------------
  ; Mouse handling
  ; -----------------------------------------------------------------

  (define last-click-x #f)
  (define last-click-y #f)
  (define num-unproductive-clicks 0)

  (define (jewel-mouse-down button x y)
    (set! down-x x)
    (set! down-y y)
    (set! isdown? #t)
    (set! num-unproductive-clicks (add1 num-unproductive-clicks))
    (set! need-help? (num-unproductive-clicks . > . 5))
    (let ([pos (getpos x y)])
      (when pos
	(set! last-click-x (vector-ref pos 0))
	(set! last-click-y (vector-ref pos 1))))
    (set! bubble-x #f)
    (set! bubble-y #f)
    (set! revert-bubble-x #f)
    (set! revert-bubble-y #f)
  )


  (define (jewel-mouse-up button x y)
    (set! isdown? #f)
  )
  
  (define (jewel-key-move dx dy)
    (if (and locked?
	     (equal? gamestate   'PLAYING)
	     (equal? action-mode 'ACTION-WAITING)
	     bubble-x
	     bubble-y
	     (<= 0 (+ bubble-x dx) (sub1 ex))
	     (<= 0 (+ bubble-y dy) (sub1 ey)))
	(let ([bx bubble-x]
	      [by bubble-y])
	  (set! revert-bubble-x bx)
	  (set! revert-bubble-y by)
	  (set! bubble-x (+ bubble-x dx))
	  (set! bubble-y (+ bubble-y dy))
	  (try-to-swap bx by dx dy))
	(begin
	  (set! revert-bubble-x #f)
	  (set! revert-bubble-y #f)
	  (set! bubble-x
		(cond
		 [bubble-x (max 0 (min (sub1 ex) (+ bubble-x dx)))]
		 [last-click-x last-click-x]
		 [(dx . >= . 0) 0]
		 [else (- ex 1)]))
	  (set! bubble-y
		(cond
		 [bubble-y (max 0 (min (sub1 ex) (+ bubble-y dy)))]
		 [last-click-y last-click-y]
		 [(dy . >= . 0) 0]
		 [else (- ey 1)]))))
    (set! isdown? #f)
  )

  (define (jewel-key-lock)
    (set! locked? (not locked?))
    (set! isdown? #f)
    ) 
  
  
  ; from the mouse position determine which object will be selected
  (define (getpos mx my)
  
    (let*
      ( (screen (make-vector 4))
        (v0 (vector-ref viewport 0))
        (v1 (vector-ref viewport 1))
        (v2 (vector-ref viewport 2))
        (v3 (vector-ref viewport 3))
        (world #f)
      )
      (vector-set! screen 0 (- (/ (* (- mx v0) 2.0) v2) 1.0))
      (vector-set! screen 1 (- (/ (* (- my v1) 2.0) v3) 1.0))
      (vector-set! screen 2 0.27272727)
      (vector-set! screen 3 1.0)
    
      (set! world (array-mult-vector unproject_matrix screen))
    
      (if (= (vector-ref world 3) 0.0)
        (make-vector 2 -1)
        (let*
          ( (w0 (vector-ref world 0))
            (w1 (vector-ref world 1))
            (w2 (vector-ref world 2))
            (w3 (vector-ref world 3))
            (z (/ w2 w3))
            (x (+ (/ (- (* z (/ w0 w3)) shiftx) spacing) (/ ex 2)))
            (y (+ (/ (- (* z (/ w1 w3)) shifty) spacing) (/ ey 2)))
            (vect (make-vector 2 0))
          )
          (if (>= x 0.0)
            (set! x (inexact->exact (truncate x)))
            (set! x -1)
          )
          (if (>= y 0.0)
            (set! y (inexact->exact (truncate y)))
            (set! y -1)
          )
          (vector-set! vect 0 x)
          (vector-set! vect 1 y)
          
          vect
        )
      )
    )
  )


  (define (jewel-mouse-motion x y)
    (let*
      ( (pos (getpos x y))
        (dx  (if isdown? (- x down-x) 0.0))
        (dy  (if isdown? (- y down-y) 0.0))
        (px  #f) 
        (py  #f)
      )
      (set! cposx (vector-ref pos 0))
      (set! cposy (vector-ref pos 1))
    
      ; if mouse was pressed, 
      ;    we are playing,
      ;    no action is happening
      ;    and mouse is moved, so try to swap
      (if (and isdown? 
               (equal? gamestate   'PLAYING)
               (equal? action-mode 'ACTION-WAITING)
               (> (+ (* dx dx) (* dy dy)) (* dist dist))
          )
        (begin
          (set! isdown? #f)
          (if (> (abs dx) (abs dy))
            (begin
              (if (< dx 0) 
                (set! dx -1)
                (set! dx 1)
              )
              (set! dy 0)
            )
            (begin
              (if (< dy 0)
                (set! dy -1)
                (set! dy 1)
              )
              (set! dx 0)
            )
          )
          
          (set! pos (getpos down-x down-y))
          (set! px  (vector-ref pos 0))
          (set! py  (vector-ref pos 1))
          (when (not (or (< px 0.0)
			 (>= px ex)
			 (< py 0.0)
			 (>= py ey)
			 (< (+ px dx) 0.0)
			 (>= (+ px dx) ex)
			 (< (+ py dy) 0.0)
			 (>= (+ py dy) ey)))
	    (set! num-unproductive-clicks 0)
	    (set! need-help? #f)
	    (try-to-swap px py dx dy)
          )
        )
      )
    )
  )

  (define (try-to-swap px py dx dy)
    (element-swap! py px (+ py dy) (+ px dx))
    ;; mark the elements for the swap
    (element-set! py px 'swapping 1)
    (element-set! py px 'dx dx)
    (element-set! py px 'dy (- dy))
    (element-set! (+ py dy) (+ px dx) 'swapping 1)
    (element-set! (+ py dy) (+ px dx) 'dx (- dx))
    (element-set! (+ py dy) (+ px dx) 'dy dy)
    (set! tryswap? #t))

  ; -----------------------------------------------------------------
  ; MAIN
  ; -----------------------------------------------------------------

  (jewel-init-game)

  (define show-jewel-help
    (show-help (list "games" "jewel")
	       "Jewel Help" #f))

  (define *MAIN_WINDOW* 
          (new jewel-frame%
               (label "Jewel")
               (min-width 640)
               (min-height 480)
               (stretchable-width #f)
               (stretchable-height #f)
          )
  )

  (define *OPENGL_WINDOW* 
          (new jewel-canvas% (parent *MAIN_WINDOW*)
                             (min-width 100)
                             (min-height 100)
                             (expose        jewel-redraw)
                             (realize       jewel-realize)
                             (configure     jewel-configure)
                             (mouse-press   jewel-mouse-down)
                             (mouse-motion  jewel-mouse-motion)
                             (mouse-release jewel-mouse-up)
          )
  )

  (send *MAIN_WINDOW* show #t)
    
  (define *TIMER* (new timer% 
                       (notify-callback jewel-control-game)
                       (interval        timer-interval)
                       (just-once?      #f)
                   )
  )

)))
