(module checkers mzscheme
  (require (lib "gl-board.ss" "games" "gl-board-game")
           (lib "class.ss")
           (lib "math.ss")
           (lib "mred.ss" "mred")
           (lib "gl-vectors.ss" "sgl")
           (prefix gl- (lib "sgl.ss" "sgl"))
           (lib "gl.ss" "sgl")
           (lib "array.ss" "srfi" "25")
           (lib "unit.ss")
           "honu-bitmaps.ss")
  
  (provide game-unit)

  (define path (collection-path "games" "checkers"))
  
  (define-struct image (width height rgba))
  
  (define (argb->rgba argb)
    (let* ((length (bytes-length argb))
           (rgba (make-gl-ubyte-vector length)))
      (let loop ((i 0))
        (when (< i length)
          (gl-vector-set! rgba (+ i 0) (bytes-ref argb (+ i 1)))
          (gl-vector-set! rgba (+ i 1) (bytes-ref argb (+ i 2)))
          (gl-vector-set! rgba (+ i 2) (bytes-ref argb (+ i 3)))
          (gl-vector-set! rgba (+ i 3) (bytes-ref argb (+ i 0)))
          (loop (+ i 4))))
      rgba))
  
  (define (bitmap->argb bmp)
    (let* ((width (send bmp get-width))
           (height (send bmp get-height))
           (argb (make-bytes (* 4 width height) 255))
           (dc (make-object bitmap-dc% bmp)))
      (send dc get-argb-pixels 0 0 width height argb #f)
      (when (send bmp get-loaded-mask)
        (send dc set-bitmap (send bmp get-loaded-mask))
        (send dc get-argb-pixels 0 0 width height argb #t))
      (send dc set-bitmap #f)
      argb))
  
  (define (bitmap->image bmp)
    (make-image (send bmp get-width) (send bmp get-height)
                (argb->rgba (bitmap->argb bmp))))

  (define (file->image file)
    (bitmap->image (make-object bitmap% file)))
  
  (define light-square-img (file->image (build-path path "light.jpg")))
  (define light-square-color (gl-float-vector .7216 .6471 .5176 1))
  (define dark-square-img (file->image (build-path path "dark.jpg")))
  (define dark-square-color (gl-float-vector .4745 .3569 .2627 1))
  
  (define (color-name->vector name darken?)
    (let ([color (send the-color-database find-color name)]
          [adj (if darken? sqr values)])
      (unless color
        (error 'color-name->vector "could not find ~e" name))
      (gl-float-vector (adj (/ (send color red) 255))
                       (adj (/ (send color green) 255))
                       (adj (/ (send color blue) 255))
                       1.0)))
  
  (define light-checker-img (bitmap->image honu-down-bitmap))
  (define dark-checker-img (bitmap->image honu-bitmap))
  
  (define-struct space-info (x y light?))
  (define-struct piece-info (x y color king?) (make-inspector))
  (define-struct moves (list forced-jump?))

  (define checkers-view@
    (unit
      (import move)
      (export add-space add-piece remove-piece move-piece set-turn show)

      (define (get-space-draw-fn space)
        (let* ((list-id (get-square-dl (space-info-light? space)
                                       (send texture-box get-value)))
               (sx (space-info-x space))
               (sy (space-info-y space)))
          (lambda ()
            (gl-push-matrix)
            (gl-translate sx sy 0)
            (gl-call-list list-id)
            (gl-pop-matrix))))
      
      (define (add-space space)
        (send board add-space (get-space-draw-fn space) space))

      (define (get-piece-draw-fn piece glow?)
        (let ((list-id (get-checker-dl (eq? 'red (piece-info-color piece))
                                       (piece-info-king? piece)
                                       (send texture-box get-value))))
          (if glow?
              (lambda (for-shadow?)
                (gl-material-v 'front 'emission (gl-float-vector 0.15 0.15 0.15 1.0))
                (gl-call-list ((if for-shadow? cdr car) list-id))
                (gl-material-v 'front 'emission (gl-float-vector 0.0 0.0 0.0 1.0)))
              (lambda (for-shadow?)
                (gl-call-list ((if for-shadow? cdr car) list-id))))))
      
      (define add-piece
        (case-lambda
          ((piece) (add-piece piece #f))
          ((piece glow?)
           (send board add-piece (+ .5 (piece-info-x piece)) (+ .5 (piece-info-y piece)) 0.0
                 (get-piece-draw-fn piece glow?)
                 piece))))
          
      (define (move-piece from to-x to-y)
        (remove-piece from)
        (add-piece (make-piece-info to-x to-y (piece-info-color from) (piece-info-king? from))))
      
      (define (remove-piece p)
        (send board remove-piece p))

      (define (internal-move old move-to)
        (when (piece-info? old)
          (move old move-to)))

      (define (set-turn turn moves)
	(let* ([pieces (send board get-pieces)])
	  (for-each (lambda (p)
                      (send board set-piece-draw p
                            (get-piece-draw-fn p #f))
                      (send board enable-piece p #f))
		    pieces)
	  (for-each (lambda (p)
                      (send board set-piece-draw p
                            (get-piece-draw-fn p #t))
                      (send board enable-piece p #t))
                    (moves-list moves)))
	(send msg set-label
	      (if (null? (moves-list moves))
		  (format "~a wins!" (if (eq? turn 'red) "Black" "Red"))
		  (format "~a's turn~a" 
			  (if (eq? turn 'red) "Red" "Black")
			  (if (moves-forced-jump? moves)
			      " - must take jump"
			      "")))))
      
      (define f (new frame% (label "Checkers") (width 800) (height 600)))
      (define board
        (new gl-board% (parent f) (who "Checkers")
	     (min-x 0.0) (max-x 8.0) (min-y 0.0) (max-y 8.0)
             (lift .35)
             (move internal-move)))
      (define hp (new horizontal-pane% (parent f) (stretchable-height #f)))
      (define msg
	(new message% (label "") (parent hp) (stretchable-width #t)))
      (define texture-box
        (new check-box% (label "Textured") (parent hp)
             (callback
              (lambda (box _)
                (for-each
                 (lambda (s)
                   (send board set-space-draw s
                         (get-space-draw-fn s)))
                 (send board get-spaces))
                (for-each
                 (lambda (p)
                   (send board set-piece-draw p
                         (get-piece-draw-fn p (send board enabled? p))))
                 (send board get-pieces))
                (send board refresh)))))
      (send texture-box set-value #t)
                
      (define q
        (send board with-gl-context
          (lambda () (gl-new-quadric))))

      (define-values (dark-tex light-tex dark-checker-tex light-checker-tex)
        (send board with-gl-context
          (lambda ()
            (let ((x (glGenTextures 4)))
              (values
               (gl-vector-ref x 0)
               (gl-vector-ref x 1)
               (gl-vector-ref x 2)
               (gl-vector-ref x 3))))))
      
      (define (init-tex tex img)
        (send board with-gl-context
              (lambda ()
                (glBindTexture GL_TEXTURE_2D tex)
                (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR)
                (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR)
                (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP)
                (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP)
                (glTexImage2D GL_TEXTURE_2D 0 GL_RGBA (image-width img) (image-height img) 0
                              GL_RGBA GL_UNSIGNED_BYTE (image-rgba img)))))
      
      (init-tex light-tex light-square-img)
      (init-tex dark-tex dark-square-img)
      (init-tex dark-checker-tex dark-checker-img)
      (init-tex light-checker-tex light-checker-img)
      
      (define (make-piece-dl color height tex shadow?)
        (send board with-gl-context
              (lambda ()
                (let ((list-id (gl-gen-lists 1)))
                  (gl-quadric-draw-style q 'fill)
                  (gl-quadric-normals q 'smooth)
                  (gl-new-list list-id 'compile)
                  
                  (when shadow?
                    (gl-disable 'lighting))
                  (gl-material-v 'front 'specular (gl-float-vector 1.0 1.0 1.0 1.0))
                  (gl-material 'front 'shininess 120.0)  
                  
                  (gl-material-v 'front 'ambient-and-diffuse color)
                  (gl-cylinder q .35 .35 height 25 1)
                  (gl-push-matrix)
                  (gl-translate 0.0 0.0 height)
                  
                  (when (and tex (not shadow?))
                    (gl-enable 'texture-2d)
                    (glBindTexture GL_TEXTURE_2D tex)
                    (glTexEnvf GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE GL_DECAL)
                    (gl-quadric-texture q #t))
                  
                  (gl-disk q 0.0 .35 25 1)
                  
                  (when (and tex (not shadow?))
                    (gl-quadric-texture q #f)
                    (glTexEnvf GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE GL_MODULATE)
                    (gl-disable 'texture-2d))
                  
                  (gl-pop-matrix)
                  
                  (when shadow?
                    (gl-enable 'lighting))
                  (gl-end-list)
                  list-id))))

      (define (make-tex-square-dl tex)
        (send board with-gl-context
          (lambda ()
            (let ((list-id (gl-gen-lists 1)))
              (gl-new-list list-id 'compile)
              (gl-enable 'texture-2d)
              (glBindTexture GL_TEXTURE_2D tex)
              (gl-material-v 'front 'ambient-and-diffuse
                             (gl-float-vector 1 1 1 1))
              (gl-begin 'polygon)
              (gl-tex-coord 0.0 0.0)
              (gl-vertex 0.0 0.0 0.0)
              (gl-tex-coord 1.0 0.0)
              (gl-vertex 1.0 0.0 0.0)
              (gl-tex-coord 1.0 1.0)
              (gl-vertex 1.0 1.0 0.0)
              (gl-tex-coord 0.0 1.0)
              (gl-vertex 0.0 1.0 0.0)
              (gl-end)
              (gl-disable 'texture-2d)
              (gl-end-list)
              list-id))))

      (define (make-square-dl color)
        (send board with-gl-context
          (lambda ()
            (let ((list-id (gl-gen-lists 1)))
              (gl-new-list list-id 'compile)
              (gl-material-v 'front 'ambient-and-diffuse color)
              (gl-begin 'polygon)
              (gl-vertex 0.0 0.0 0.0)
              (gl-vertex 1.0 0.0 0.0)
              (gl-vertex 1.0 1.0 0.0)
              (gl-vertex 0.0 1.0 0.0)
              (gl-end)
              (gl-end-list)
              list-id))))
      
      (define checkers
        (map
         (lambda (x)
           (let ((color (if (car x)
                            (color-name->vector "firebrick" #t)
                            (gl-float-vector 0.15 0.15 0.15 1.0)))
                 (height (if (cadr x) .4 .2))
                 (tex (if (caddr x) (if (car x) light-checker-tex dark-checker-tex) #f)))
             (cons x (cons (make-piece-dl color height tex #f)
                           (make-piece-dl color height tex #t)))))
         '((#f #f #f)
           (#f #f #t)
           (#f #t #f)
           (#f #t #t)
           (#t #f #f)
           (#t #f #t)
           (#t #t #f)
           (#t #t #t))))
      (define (get-checker-dl light? king? tex?)
        (cdr (assoc (list light? king? tex?) checkers)))
        
      (define dark-square (cons (make-tex-square-dl dark-tex)
                                (make-square-dl dark-square-color)))
      (define light-square (cons (make-tex-square-dl light-tex)
                                 (make-square-dl light-square-color)))
      (define (get-square-dl light? tex?)
        (let ((getter (if tex? car cdr)))
          (getter (if light? light-square dark-square))))
                         
      (define (show)
        (send f show #t))))
  
  (define checkers-model@
    (unit
      (import add-space add-piece remove-piece move-piece set-turn)
      (export move)

      (define turn 'red)
      (define board (make-array (shape 0 8 0 8) #f))
      
      (let loop ((i 0)
                 (j 0))
        (cond
          ((and (< j 8) (< i 8))
           (cond
             ((even? (+ i j))
              (add-space (make-space-info j i #f))
              (cond
                ((< i 3)
                 (array-set! board j i (cons 'red #f))
                 (add-piece (make-piece-info j i 'red #f)))
                ((> i 4)
                 (array-set! board j i (cons 'black #f))
                 (add-piece (make-piece-info j i 'black #f)))))
             (else
              (add-space (make-space-info j i #t))))
           (loop i (add1 j)))
          ((< i 8) (loop (add1 i) 0))))

      (define (other-color c)
        (cond
          ((eq? c 'red) 'black)
          (else 'red)))
      
      (define (single-move-ok? direction from-x from-y to-x to-y)
        (and (= to-y (+ direction from-y))
             (= 1 (abs (- from-x to-x)))))

      (define (can-move? direction from-x from-y)
	(and (<= 0 (+ from-y direction) 7)
	     (or (and (<= 0 (+ from-x 1) 7)
		      (not (array-ref board (+ from-x 1) (+ from-y direction))))
		 (and (<= 0 (+ from-x -1) 7)
		      (not (array-ref board (+ from-x -1) (+ from-y direction)))))))
      
      (define (get-jumped-piece color direction from-x from-y to-x to-y)
        (and (= to-y (+ direction direction from-y))
             (= 2 (abs (- from-x to-x)))
             (let* ((jumped-x (+ from-x (/ (- to-x from-x) 2)))
                    (jumped-y (+ from-y direction))
                    (jumped-piece (array-ref board jumped-x jumped-y)))
               (and jumped-piece
                    (eq? (other-color color) (car jumped-piece))
                    (make-piece-info jumped-x jumped-y (car jumped-piece) (cdr jumped-piece))))))
      
      (define (can-jump? direction from-color from-x from-y)
        (let ((to-y (+ direction direction from-y))
              (to-x1 (+ from-x 2))
              (to-x2 (- from-x 2)))
          (and (<= 0 to-y 7)
               (or (and (<= 0 to-x1 7)
                        (not (array-ref board to-x1 to-y))
                        (get-jumped-piece from-color direction
                                          from-x from-y
                                          to-x1 to-y))
                   (and (<= 0 to-x2)
                        (not (array-ref board to-x2 to-y))
                        (get-jumped-piece from-color direction
                                          from-x from-y
                                          to-x2 to-y))))))
      

      (define (fold-board f v)
	(let iloop ([i 0][v v])
	  (if (= i 8)
	      v
	      (let jloop ([j 0][v v])
		(if (= j 8)
		    (iloop (add1 i) v)
		    (jloop (add1 j) 
			   (if (even? (+ i j)) 
			       (f i j v)
			       v))))))) 

      (define (get-jump-moves)
	(let ([direction (if (eq? turn 'red) 1 -1)])
	  (fold-board
	   (lambda (i j l)
	     (let ([p (array-ref board i j)])
	       (if (and p
			(eq? (car p) turn)
			(or (can-jump? direction turn i j)
			    (and (cdr p)
				 (can-jump? (- direction) turn i j))))
		   (cons (make-piece-info i j turn (cdr p)) l)
		   l)))
	   null)))

      (define (get-moves)
	(let ([jumps (get-jump-moves)])
	  (if (pair? jumps)
	      (make-moves jumps #t)
	      (make-moves
	       (let ([direction (if (eq? turn 'red) 1 -1)])
		 (fold-board
		  (lambda (i j l)
		    (let ([p (array-ref board i j)])
		      (if (and p
			       (eq? (car p) turn)
			       (or (can-move? direction i j)
				   (and (cdr p)
					(can-move? (- direction) i j))))
			  (cons (make-piece-info i j turn (cdr p)) l)
			  l)))
		  null))
	       #f))))

      (define (move from to)
        (let* ((to-x (inexact->exact (floor (gl-vector-ref to 0))))
               (to-y (inexact->exact (floor (gl-vector-ref to 1))))
               (from-x (piece-info-x from))
               (from-y (piece-info-y from))
               (from-color (piece-info-color from))
               (from-king? (piece-info-king? from))
               (to-king? (or from-king?
                             (if (eq? 'red from-color)
                                 (= to-y 7)
                                 (= to-y 0))))
               (direction (if (eq? turn 'red) 1 -1)))
          (when (and (eq? turn from-color)
                     (<= 0 to-x 7)
                     (<= 0 to-y 7)
                     (not (array-ref board to-x to-y)))
            (cond
              ((and (null? (get-jump-moves))
		    (or (single-move-ok? direction from-x from-y to-x to-y)
			(and from-king?
			     (single-move-ok? (- direction) from-x from-y to-x to-y))))
	       (move-piece from to-x to-y)
               (set! turn (other-color from-color))
               (array-set! board to-x to-y (cons from-color to-king?))
               (array-set! board from-x from-y #f)
               (when (and to-king? (not from-king?))
                 (remove-piece (make-piece-info to-x to-y from-color from-king?))
                 (add-piece (make-piece-info to-x to-y from-color to-king?)))
	       (set-turn turn (get-moves)))
              ((or (get-jumped-piece from-color direction from-x from-y to-x to-y)
		   (and from-king?
			(get-jumped-piece from-color (- direction) from-x from-y to-x to-y)))
               =>
               (lambda (j)
                 (remove-piece j)
                 (move-piece from to-x to-y)
                 (array-set! board (piece-info-x j) (piece-info-y j) #f)
                 (array-set! board from-x from-y #f)
                 (array-set! board to-x to-y (cons from-color to-king?))
                 (when (and to-king? (not from-king?))
                   (remove-piece (make-piece-info to-x to-y from-color from-king?))
                   (add-piece (make-piece-info to-x to-y from-color to-king?)))
                 (cond
                   ((or (can-jump? direction from-color to-x to-y)
                        (and from-king?
                             (can-jump? (- direction) from-color to-x to-y)))
                    (set-turn turn (make-moves (list (make-piece-info to-x to-y from-color to-king?)) #t)))
                   (else
                    (set! turn (other-color from-color))
                    (set-turn turn (get-moves))))))))))

      (set-turn turn (get-moves))
      ))
              
  (define game-unit
   (compound-unit 
     (import)
     (link 
      (VIEW (checkers-view@ (MODEL move)))
      (MODEL (checkers-model@ (VIEW add-space add-piece remove-piece move-piece set-turn)))
      (SHOW ((unit (import show) (export) (show)) (VIEW show))))
     (export)))
  )
