(import scheme)
(import (chicken base))
(import (chicken file))
(import (chicken format))
(import (chicken io))
(import (chicken string))
(import (chicken pathname))
(import (chicken process))
(import (chicken process-context))
(import (chicken process signal))
(import (chicken random))
(import gtk-server)

;;; Util

(define (read-string* #!optional num port)
  (let ((output (read-string num port)))
    (if (eof-object? output)
        ""
        output)))

(define (capture command-string)
  (call-with-input-pipe command-string
    (lambda (in)
      (string-chomp (read-string* #f in)))))

(define (// a b)
  (inexact->exact (floor (/ a b))))

;;; GUI setup

(define gtk-server (start-gtk-server!))
(define (gtk #!rest args) (apply gtk-send! gtk-server args))

;; Define GUI - mainwindow
(define window (gtk "m_window" "\"'Scheme-Tris using H.U.G.'\"" 335 420))
(gtk "m_bgcolor" window "#BBBBFF")
(define frame1 (gtk "m_frame" 210 410))
(gtk "m_bgcolor" frame1 "#BBBBFF")
(gtk "m_attach" window frame1 5 5)
(define canvas (gtk "m_canvas" 200 400))
(gtk "m_attach" window canvas 10 10)
(define frame2 (gtk "m_frame" 110 70))
(gtk "m_bgcolor" frame2 "#BBBBFF")
(gtk "m_attach" window frame2 220 5)
(define example (gtk "m_canvas" 100 60))
(gtk "m_attach" window example 225 10)
(define frame7 (gtk "m_frame" 110 50))
(gtk "m_frame_text" frame7 "\"' Lines next level '\"")
(gtk "m_fgcolor" frame7 "#0000FF")
(gtk "m_bgcolor" frame7 "#BBBBFF")
(gtk "m_attach" window frame7 220 80)
(define tlabel (gtk "m_label" 10 100 20 0.5 0.5))
(gtk "m_fgcolor" tlabel "#4444FF")
(gtk "m_attach" window tlabel 225 105)
(define frame6 (gtk "m_frame" 110 50))
(gtk "m_frame_text" frame6 "\"' Level '\"")
(gtk "m_fgcolor" frame6 "#0000FF")
(gtk "m_bgcolor" frame6 "#BBBBFF")
(gtk "m_attach" window frame6 220 140)
(define llabel (gtk "m_label" 1 100 20 0.5 0.5))
(gtk "m_fgcolor" llabel "#4444FF")
(gtk "m_attach" window llabel 225 165)
(define frame4 (gtk "m_frame" 110 50))
(gtk "m_frame_text" frame4 "\"' Score '\"")
(gtk "m_fgcolor" frame4 "#0000FF")
(gtk "m_bgcolor" frame4 "#BBBBFF")
(gtk "m_attach" window frame4 220 200)
(define slabel (gtk "m_label" 0 100 20 0.5 0.5))
(gtk "m_fgcolor" slabel "#4444FF")
(gtk "m_attach" window slabel 225 225)
(define frame5 (gtk "m_frame" 110 50))
(gtk "m_frame_text" frame5 "\"' Highscore '\"")
(gtk "m_fgcolor" frame5 "#0000FF")
(gtk "m_bgcolor" frame5 "#BBBBFF")
(gtk "m_attach" window frame5 220 260)
(define hlabel (gtk "m_label" 0 100 20 0.5 0.5))
(gtk "m_fgcolor" hlabel "#4444FF")
(gtk "m_attach" window hlabel 225 285)
(define restart (gtk "m_stock" 'gtk-refresh 110 35))
(gtk "m_bgcolor" restart "#8888FF" "#8888FF" "#AAAAFF")
(gtk "m_attach" window restart 220 320)
(gtk "m_unfocus" restart)
(define exit (gtk "m_stock" 'gtk-quit 110 35))
(gtk "m_bgcolor" exit "#8888FF" "#8888FF" "#AAAAFF")
(gtk "m_attach" window exit 220 380)
(gtk "m_unfocus" exit)

;; key enums

(define gdk-key-space (number->string #x20))
(define gdk-key-n (number->string #x6e))
(define gdk-key-p (number->string #x70))
(define gdk-key-q (number->string #x71))
(define gdk-key-x (number->string #x78))
(define gdk-key-z (number->string #x7a))
(define gdk-key-left (number->string #xff51))
(define gdk-key-up (number->string #xff52))
(define gdk-key-right (number->string #xff53))
(define gdk-key-down (number->string #xff54))

;;; Global variables

(define levels #(500 400 320 256 204 164 132 116 93 75 60 48))

(define background-color "#FFFFFF")
(define shape-colors
  #("#22CCCC" "#FF2222" "#22FF22" "#DDDD00" "#FF22FF" "#FFA500" "#2222FF"))

(define blank -1)
(define width 10)
(define height 20)
(define cell-width 20)
(define cell-height 20)
(define gamegrid (make-vector (* width height) blank))

(define shapes
  #(#(#(#(0  0) #(1  0) #(0  1) #(1  1))) ; O

    #(#(#(0  0) #(1  0) #(2  0) #(2  1)) ; J
      #(#(1 -1) #(1  0) #(1  1) #(0  1))
      #(#(0 -1) #(0  0) #(1  0) #(2  0))
      #(#(1 -1) #(2 -1) #(1  0) #(1  1)))

    #(#(#(0  0) #(1  0) #(2  0) #(0  1)) ; L
      #(#(0 -1) #(1 -1) #(1  0) #(1  1))
      #(#(2 -1) #(0  0) #(1  0) #(2  0))
      #(#(1 -1) #(1  0) #(1  1) #(2  1)))

    #(#(#(0  0) #(1  0) #(1  1) #(2  1)) ; Z
      #(#(1  0) #(0  1) #(1  1) #(0  2)))

    #(#(#(1  0) #(2  0) #(0  1) #(1  1)) ; S
      #(#(0  0) #(0  1) #(1  1) #(1  2)))

    #(#(#(1  0) #(0  1) #(1  1) #(2  1)) ; T
      #(#(1  0) #(1  1) #(2  1) #(1  2))
      #(#(0  1) #(1  1) #(2  1) #(1  2))
      #(#(1  0) #(0  1) #(1  1) #(1  2)))

    #(#(#(0  0) #(1  0) #(2  0) #(3  0)) ; I
      #(#(1 -1) #(1  0) #(1  1) #(1  2)))))

;; the scoring rules were taken from "xtetris".  Blocks score differently
;; depending on their rotation

(define shape-scores
  #(#(6) #(6 7 6 7) #(6 7 6 7) #(6 7) #(6 7) #(5 5 6 5) #(5 8)))

(define shape-dimensions
  #(#(2 2) #(3 2) #(3 2) #(3 2) #(3 2) #(3 2) #(4 1)))

(define cur-shape 0)
(define next-shape 0)
(define cur-rotation 0)
(define n-rows 0)
(define score 0)
(define pos-x 0)
(define pos-y 0)
(define state-stopped -1)
(define state-running 0)
(define state-paused 1)
(define current-state state-running)

;;; Game functions

(define highscore-path
  (make-pathname (get-environment-variable "HOME") ".tetris.rc"))

(define (highscore-ref)
  (if (file-exists? highscore-path)
      (call-with-input-file highscore-path read)
      0))

(define (highscore-set! value)
  (call-with-output-file highscore-path
    (lambda (out)
      (display value out)
      (newline out))))

(define (draw-cell! canvas x y fill)
  ;; Set canvas to draw
  (gtk "m_draw" canvas)
  (let ((x (* x cell-width))
        (y (* y cell-height)))
    (if (= fill blank)
        (gtk "m_square" background-color x y 20 20 1)
        (gtk "m_square" (vector-ref shape-colors fill) x y 19 19 1))))

(define (gamegrid-set! x y fill)
  (vector-set! gamegrid (+ (* y width) x) fill)
  (draw-cell! canvas x y fill))

(define (gamegrid-ref x y)
  (vector-ref gamegrid (+ (* y width) x)))

(define (gamegrid-redraw!)
  (let loop ((x 0))
    (when (< x width)
      (let loop ((y 0))
        (when (< y height)
          (draw-cell! canvas x y (gamegrid-ref x y))
          (loop (+ y 1))))
      (loop (+ x 1)))))

(define (get-shape-cell block #!optional (shape cur-shape) (rot cur-rotation))
  (vector-ref (vector-ref (vector-ref shapes shape)
                          rot)
              block))

(define (shape-width #!optional (shape cur-shape))
  (vector-ref (vector-ref shape-dimensions shape) 0))

(define (shape-height #!optional (shape cur-shape))
  (vector-ref (vector-ref shape-dimensions shape) 1))

(define (shape-rotations)
  (vector-length (vector-ref shapes cur-shape)))

(define (kill-timer!)
  (set! current-state state-stopped))

(define (start-timer!)
  (set! current-state state-running)
  (gtk "m_timeout" window (vector-ref levels 0)))

(define (update-score!)
  (gtk "m_timeout" window (vector-ref levels (// n-rows 10)))
  (gtk "m_label_text" slabel score)
  (gtk "m_label_text" llabel (+ (// n-rows 10) 1))
  (gtk "m_label_text" tlabel (- 10 (modulo n-rows 10))))

(define (new-shape!)
  (set! cur-shape next-shape)
  (set! cur-rotation 0)
  (set! next-shape (pseudo-random-integer 7))
  (set! pos-x (// (- width (shape-width)) 2))
  (set! pos-y 0)
  (if (shape-collision?)
      (end-game!)
      (begin
        (draw-shape!)
        (draw-next-shape!)
        (update-score!))))

(define (draw-next-shape!)
  ;; Set canvas
  (gtk "m_draw" example)
  ;; Clear canvas
  (gtk "m_square" background-color 0 0 100 60 1)
  (let loop ((i 0))
    (when (< i 4)
      (let ((c (get-shape-cell i next-shape 0)))
        (let* ((next-width (* (shape-width next-shape) cell-width))
               (next-height (* (shape-height next-shape) cell-height))
               (x-offset (/ (- 100 next-width) 2.0))
               (y-offset (/ (- 60 next-height) 2.0))
               (x (+ (* (vector-ref c 0) cell-width) x-offset))
               (y (+ (* (vector-ref c 1) cell-height) y-offset))
               (fill (vector-ref shape-colors next-shape)))
          (gtk "m_square" fill x y 19 19 1)))
      (loop (+ i 1)))))

(define (draw-or-erase-shape! fill)
  (let loop ((i 0))
    (when (< i 4)
      (let ((c (get-shape-cell i)))
        (gamegrid-set! (+ pos-x (vector-ref c 0))
                       (+ pos-y (vector-ref c 1))
                       fill))
      (loop (+ i 1)))))

(define (draw-shape!) (draw-or-erase-shape! cur-shape))
(define (erase-shape) (draw-or-erase-shape! blank))

(define (shape-collision?)
  (call-with-current-continuation
   (lambda (return)
     (let loop ((i 0))
       (when (< i 4)
         (let* ((c (get-shape-cell i))
                (xx (+ pos-x (vector-ref c 0)))
                (yy (+ pos-y (vector-ref c 1))))
           (when (or (>= xx width) (< xx 0)
                     (>= yy height) (< yy 0)
                     (not (= (gamegrid-ref xx yy)
                             blank)))
             (return #t)))
         (loop (+ i 1))))
     #f)))

(define (full-row? y)
  (call-with-current-continuation
   (lambda (return)
     (let loop ((x 0))
       (when (< x width)
         (when (= (gamegrid-ref x y)
                  blank)
           (return #f))
         (loop (+ x 1))))
     #t)))

(define (shift-row! y)
  (if (zero? y)
      (let loop ((x 0))
        (when (< x width)
          (gamegrid-set! x y blank)
          (loop (+ x 1))))
      (let loop ((x 0))
        (when (< x width)
          (let ((c (gamegrid-ref x (- y 1))))
            (gamegrid-set! x y c))
          (loop (+ x 1))))))

(define (shift-down!)
  (let loop ((y0 0))
    (when (< y0 height)
      (when (full-row? y0)
        (set! n-rows (+ n-rows 1))
        (let loop ((y y0))
          (when (>= y 0)
            (shift-row! y)
            (loop (- y 1)))))
      (loop (+ y0 1)))))

(define (init-board!)
  (let loop ((y 0))
    (when (< y height)
      (let loop ((x 0))
        (when (< x width)
          (gamegrid-set! x y blank)
          (loop (+ x 1))))
      (loop (+ y 1)))))

(define (reset-game!)
  (kill-timer!)
  (init-board!)
  (set! next-shape (pseudo-random-integer 7))
  (set! cur-shape 0)
  (set! cur-rotation 0)
  (set! pos-x 0)
  (set! pos-y 0)
  (set! n-rows 0)
  (set! score 0)
  (new-shape!))

(define (shape-done!)
  (shift-down!)
  (set! score (+ score (vector-ref (vector-ref shape-scores cur-shape)
                                   cur-rotation)))
  (update-score!)
  (new-shape!))

;; Called on each tick.
;; Drops the shape one square, testing for collision.
(define (update-game!)
  (when (= current-state state-running)
    (erase-shape)
    (set! pos-y (+ pos-y 1))
    (let ((hit (shape-collision?)))
      (when hit
        (set! pos-y (- pos-y 1)))
      (draw-shape!)
      (when hit
        (shape-done!)))))

;; Drop the shape to the bottom of the playing area.
(define (move-bottom!)
  (when (= current-state state-running)
    (erase-shape)
    (let loop ((hit #f))
      (when (not hit)
        (set! pos-y (+ pos-y 1))
        (loop (shape-collision?))))
    (set! pos-y (- pos-y 1))
    (draw-shape!)
    (shape-done!)))

;; Move the shape one square to the left.
(define (move-left!)
  (when (= current-state state-running)
    (erase-shape)
    (set! pos-x (- pos-x 1))
    (when (shape-collision?)
      (set! pos-x (+ pos-x 1)))
    (draw-shape!)))

;; Move the shape one square to the right.
(define (move-right!)
  (when (= current-state state-running)
    (erase-shape)
    (set! pos-x (+ pos-x 1))
    (when (shape-collision?)
      (set! pos-x (- pos-x 1)))
    (draw-shape!)))

;; Move the shape one square down to the bottom.
(define (move-down!)
  (when (= current-state state-running)
    (erase-shape)
    (set! pos-y (+ pos-y 1))
    (when (shape-collision?)
      (set! pos-y (- pos-y 1)))
    (draw-shape!)))

;; Rotate the shape clockwise.
(define (rotate-prev!)
  (when (= current-state state-running)
    (erase-shape)
    (set! cur-rotation (modulo (+ 1 cur-rotation) (shape-rotations)))
    (when (shape-collision?)
      (set! cur-rotation (modulo (+ 3 cur-rotation) (shape-rotations))))
    (draw-shape!)))

;; Rotate the shape anticlockwise.
(define (rotate-next!)
  (when (= current-state state-running)
    (erase-shape)
    (set! cur-rotation (modulo (+ 3 cur-rotation) (shape-rotations)))
    (when (shape-collision?)
      (set! cur-rotation (modulo (+ 1 cur-rotation) (shape-rotations))))
    (draw-shape!)))

;; Terminate the current game.
(define (end-game!)
  (kill-timer!)
  (let ((pos 200))
    (gtk "m_out" "\"'Game over!'\"" "#0000FF" "#FFFFFF" 60 pos)
    (let ((highscore (string->number (gtk "m_label_grab" hlabel))))
      (when (< highscore score)
        (set! pos (+ pos 40))
        (gtk "m_out" (format "\"'New highscore: ~a'\"" score) "#4444FF" "#FFFFFF" 40 pos)
        (highscore-set! score))
      (set! pos (+ pos 40))
      (gtk "m_out" "\"'Press refresh to start again'\"" "#0000FF" "#FFFFFF" 20 pos))))

;; Start a new game of Tetris.
(define (start-game!)
  (reset-game!)
  (start-timer!)
  (gtk "m_label_text" hlabel (highscore-ref))
  (gtk "m_label_text" tlabel 10)
  (gtk "m_label_text" llabel 1))

;; Pause (or resume) the current game.
(define (pause-game!)
  (cond
   ((= current-state state-paused)
    (gamegrid-redraw!)
    (set! current-state state-running))
   ((= current-state state-running)
    (gtk "m_out" "\"'Game paused'\"" "#0000FF" "#FFFFFF" 60 200)
    (gtk "m_out" "\"'Press <p> to continue'\"" "#4444FF" "#FFFFFF" 35 240)
    (set! current-state state-paused))))

;;; Main program

;; Check if we can play music
(define timidity (capture "which timidity 2>/dev/null"))
(if (equal? timidity "")
    (print "Timidity not found, no music!")
    (let ((path (pathname-replace-extension (program-name) ".mid")))
      (receive (_ _ pid) (process timidity `("-idl" "-A200" ,path))
        (let ((exit-handler (lambda _ (process-signal pid signal/kill))))
          (set-signal-handler! signal/quit exit-handler)
          (set-signal-handler! signal/term exit-handler)
          (on-exit exit-handler)))))

(start-game!)

;; Mainloop
(let loop ()
  (let ((event (gtk "m_event")))
    (when (not (equal? event exit))
      (cond
       ((equal? event restart)
        (start-game!))
       ((and (equal? event window)
             (= current-state state-running))
        (update-game!))
       ((equal? event "key-press-event")
        (let ((key (gtk "m_key")))
          (cond
           ((or (equal? key gdk-key-up)
                (equal? key gdk-key-z))
            (rotate-prev!))
           ((equal? key gdk-key-x)
            (rotate-next!))
           ((equal? key gdk-key-down)
            (move-down!))
           ((equal? key gdk-key-right)
            (move-right!))
           ((equal? key gdk-key-left)
            (move-left!))
           ((equal? key gdk-key-n)
            (start-game!))
           ((equal? key gdk-key-p)
            (pause-game!))
           ((equal? key gdk-key-q)
            (end-game!))
           ((equal? key gdk-key-space)
            (move-bottom!))))))
      (loop))))

;; Release graphical resources
(gtk "m_end")
(stop-gtk-server! gtk-server)