#! /usr/bin/env guile
!#

;;; 2048
;;; Copyright (C) 2014 David Thompson <dthompson2@worcester.edu>
;;; Copyright (C) 2014 Jordan Russell <jordan.likes.curry@gmail.com>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; Clone of the official 2048 game at http://gabrielecirulli.github.io/2048/
;;
;;; Code:

(use-modules (srfi srfi-1)
             (srfi srfi-9)
             (srfi srfi-11)
             (srfi srfi-26)
             (srfi srfi-42)
             (ice-9 match)
             (ice-9 rdelim)
             (gl)
             (sly audio)
             (sly camera)
             (sly color)
             (sly font)
             (sly game)
             (sly keyboard)
             (sly rect)
             (sly scene)
             (sly signal)
             (sly sprite)
             (sly texture)
             (sly transition)
             (sly vector)
             (sly window)
             (sly quaternion)
             (sly math)
             (sly repl))
;;;
;;; Helpers
;;;

(define* (flat-map proc lst . rest)
  (concatenate (apply map proc lst rest)))

(define (enumerate lst)
  (zip (iota (length lst)) lst))

(define (replace-at lst idx item)
  (let-values (((f d)
                (split-at lst idx)))
    (append f (cons item (cdr d)))))

;;;
;;; Game Board
;;;

(define board-size 4)

(define (double x)
  (* x 2))

(define (strip-zeros lst)
  (delete 0 lst))

(define (pad-zeros lst size)
  (append lst (make-list (max (- size (length lst)) 0) 0)))

(define merge
  (match-lambda
    ((x x . rest)
     (cons (double x) (merge rest)))
    ((x . rest)
     (cons x (merge rest)))
    (_ '())))

(define (points a b)
  (define (iter a b p)
    (cond ((or (null? a)
               (null? b))
           p)
          ((= (car a) (car b))
           (iter (cdr a) (cdr b) p))
          (else
           (iter (cddr a) (cdr b) (+ p (car b))))))
  (iter a b 0))

;; Merge list and accumulate points.
(define (merge-row row)
  (let* ((stripped (strip-zeros row))
         (merged (merge stripped)))
    (list (points stripped merged)
          (pad-zeros merged board-size))))

(define (transpose board)
  (if (null? (car board))
      '()
      (cons (map car board)
            (transpose (map cdr board)))))

(define (board-shift-left board)
  (map merge-row board))

(define (board-shift-right board)
  (map (lambda (row)
         (let ((merged (merge-row (reverse row))))
           (list (first merged) (reverse (second merged)))))
       board))

(define (board-shift-up board)
  (let-values (((points board)
                (unzip2 (board-shift-left (transpose board)))))
    (zip points (transpose board))))

(define (board-shift-down board)
  (let-values (((points board)
                (unzip2 (board-shift-right (transpose board)))))
    (zip points (transpose board))))

(define (board-shift board direction)
  (match direction
    ('up
     (board-shift-up board))
    ('down
     (board-shift-down board))
    ('left
     (board-shift-left board))
    ('right
     (board-shift-right board))
    (_ board)))

(define (board-shift-and-accum-points board direction)
  (let-values (((points board)
                (unzip2 (board-shift board direction))))
    (values (reduce + 0 points)
            board)))

(define (random-tile)
  (list-ref '(2 4) (random 2)))

(define (board-insert board)
  (let ((x (random board-size))
        (y (random board-size)))
    (let-values (((f d)
                  (split-at (list-ref board y) x)))
      (if (zero? (car d))
          (replace-at board y
                   (append f (cons (random-tile) (cdr d))))
          (board-insert board)))))

(define (board-find board n)
  (list?
   (any (lambda (row)
          (memq n row))
        board)))

(define (board-win? board)
  (board-find board 2048))

(define (board-lose? board)
  (define (full? row)
    (define (iter row prev)
      (cond ((null? row)
             #t)
            ((or (zero? (car row))
                 (= (car row) prev))
             #f)
            (else
             (iter (cdr row) (car row)))))
    (iter row 0))
  (and (every full? board)
       (every full? (transpose board))))

(define null-board
  '((0 0 0 0)
    (0 0 0 0)
    (0 0 0 0)
    (0 0 0 0)))

(define (make-board)
  (board-insert (board-insert null-board)))

;;;
;;; Game State
;;;

(define save-file
  (string-join (list (getenv "HOME") ".guile-2048")
               file-name-separator-string))

(define-record-type <2048>
  (make-2048 board score best-score)
  2048?
  (board 2048-board)
  (score 2048-score)
  (best-score 2048-best-score))

(define* (new-game #:optional (previous #f))
  (let ((best-score (if previous
                        (choose-best-score previous)
                        (load-best-score))))
    (make-2048 (make-board) 0 best-score)))

(define (load-best-score)
  (if (file-exists? save-file)
      (with-input-from-file save-file
        (lambda ()
          (let ((score (string->number (read-string))))
            (if (number? score) score 0))))
      0))

(define (save-best-score state)
  (with-output-to-file save-file
    (lambda ()
      (format #t "~d" (choose-best-score state)))))

(define (choose-best-score state)
  (max (2048-score state) (2048-best-score state)))

(define-signal controls
  (signal-filter
   (lambda (key)
     (any (cut eq? key <>)
          '(up down left right n)))
   #f key-last-down))

(define-signal 2048-state
  (signal-fold
   (lambda (key prev)
     (if (eq? key 'n)
         (new-game prev)
         (let-values (((points new-board)
                       (board-shift-and-accum-points (2048-board prev) key)))
           (let ((score (+ (2048-score prev) points)))
             ;; Only insert a new tile if there's room and the board
             ;; was actually shifted.
             (if (and (not (equal? (2048-board prev) new-board))
                      (board-find new-board 0))
                 (make-2048 (board-insert new-board) score
                            (2048-best-score prev))
                 (make-2048 new-board score (2048-best-score prev)))))))
   (new-game)
   controls))

;; For convenience
(define-signal board
  (signal-map 2048-board 2048-state))

(define-signal score-saver
  (signal-tap (lambda (state)
                (when (board-lose? (2048-board state))
                  (save-best-score state)))
              2048-state))

;;;
;;; Rendering
;;;

(open-window)
(enable-fonts)
(enable-audio)

(define background (rgb #xfaf8ef))

(define tile-texture (load-texture "tile.png"))

(define font (load-default-font 32))

(define text-color-1 (rgb #x776e65))
(define text-color-2 (rgb #xf9f6f2))

(define tile-properties
  `((0    . ((bg-color . ,(rgba #xeee4daaa))
             (text-color . ,text-color-1)))
    (2    . ((bg-color . ,(rgb #xeee4da))
             (text-color . ,text-color-1)))
    (4    . ((bg-color . ,(rgb #xede0c8))
             (text-color . ,text-color-1)))
    (8    . ((bg-color . ,(rgb #xf2b179))
             (text-color . ,text-color-2)))
    (16   . ((bg-color . ,(rgb #xf59563))
             (text-color . ,text-color-2)))
    (32   . ((bg-color . ,(rgb #xf67c5f))
             (text-color . ,text-color-2)))
    (64   . ((bg-color . ,(rgb #xf65e3b))
             (text-color . ,text-color-2)))
    (128  . ((bg-color . ,(rgb #xedcf72))
             (text-color . ,text-color-2)))
    (256  . ((bg-color . ,(rgb #xedcc61))
             (text-color . ,text-color-2)))
    (512  . ((bg-color . ,(rgb #xedc850))
             (text-color . ,text-color-2)))
    (1024 . ((bg-color . ,(rgb #xedc53f))
             (text-color . ,text-color-2)))
    (2048 . ((bg-color . ,(rgb #xedc22e))
             (text-color . ,text-color-2)))))

(define (tile-bg-color n)
  (assoc-ref (assoc-ref tile-properties n) 'bg-color))

(define (tile-text-color n)
  (assoc-ref (assoc-ref tile-properties n) 'text-color))

(define tile-sprite (make-sprite tile-texture #:anchor #(0 0)))

(define tile-label-cache
  (map (lambda (n)
         (cons n (make-label font (number->string n)
                             #:anchor 'center)))
       '(2 4 8 16 32 64 128 256 512 1024 2048)))

(define (make-tile x y n)
  (let* ((w (texture-width tile-texture))
         (h (texture-height tile-texture)))
    (scene-node
     (position (vector (* x w) (* y h)))
     (uniforms `(("color" ,(tile-bg-color n))))
     (children
      `(,tile-sprite
        ,@(if (zero? n)
              '()
              (list
               (scene-node
                (position (vector (/ w 2) (/ h 2)))
                (uniforms `(("color" ,(tile-text-color n))))
                (children
                 (list (assoc-ref tile-label-cache n)))))))))))

(define window-width 640)
(define window-height 480)
(define board-width
  (* board-size (texture-width tile-texture)))
(define board-height
  (* board-size (texture-height tile-texture)))
(define center-pos
  (vector (/ (- window-width board-width) 2)
          (- window-height board-height 8)))

(define (center v)
  (v+ v center-pos))

(define (enumerate-board board)
  (enumerate (map (cut enumerate <>) board)))

;; Transform board into a list of tile objects.
(define-signal tiles
  (signal-map
   (lambda (board)
     (flat-map
      (lambda (row)
        (let ((y (first row))
              (row (second row)))
          (map (lambda (cell)
                 (let ((x (first cell))
                       (n (second cell)))
                   (make-tile x y n)))
               row)))
      (enumerate-board board)))
   board))

(define play-again-font (load-default-font 16))

(define-signal status-message
  (signal-map
   (lambda (board)
     (let ((message (cond
                     ((board-lose? board) "GAME OVER")
                     ((board-win? board) "YOU WIN!")
                     (else #f))))
       (scene-node
        (position (center
                   (vector (/ board-width 2)
                           (/ board-height 2))))
        (uniforms `(("color" ,black)))
        (children
         (if message
             (list
              (make-label font message
                          #:color black
                          #:anchor 'bottom-center)
              (make-label play-again-font
                          "Press N to play again"
                          #:color black
                          #:anchor 'top-center))
             '())))))
   board))

(define instruction-font (load-default-font 16))

(define instruction-text
  "Use the arrow keys to join the numbers and get to the 2048 tile!")

(define-signal instructions
  (scene-node
   (position (vector (/ window-width 2) 0))
   (uniforms `(("color" ,text-color-1)))
   (children
    (list
     (make-label instruction-font
                 instruction-text
                 #:color text-color-1
                 #:anchor 'top-center)))))

(define score-header-font (load-default-font 14))
(define score-font (load-default-font 22))

(define (score-label position label score)
  (scene-node
   (position position)
   (uniforms `(("color" ,text-color-1)))
   (children
    (list
     (make-label score-header-font label
                 #:color text-color-1
                 #:anchor 'top-center)
     (signal-map
      (lambda (score)
        (scene-node
         (position (let ((pos #(0 32)))
                     (transition (v- pos #(0 8)) pos 15)))
         (uniforms `(("color" ,(transition transparent text-color-1 15))))
         (children
          (list
           (make-label score-font (number->string score)
                       #:color text-color-1
                       #:anchor 'center)))))
      (signal-drop-repeats score =))))))

(define-signal score
  (score-label (vector (+ (vx center-pos) (/ board-width 4)) 24)
               "SCORE" (signal-map 2048-score 2048-state)))

(define-signal best-score
  (score-label (vector (+ (vx center-pos)
                          (- board-width (/ board-width 4)))
                       24)
               "BEST" (signal-map 2048-best-score 2048-state)))

(define-signal 2048-scene
  (scene-root
   (scene-node
    (position (center #(0 0)))
    (children tiles))
   instructions
   score
   best-score
   status-message))

(define-signal camera
  (orthographic-camera 2048-scene window-width window-height
                       #:clear-flags '(depth-buffer)
                       #:clear-color background
                       #:before-draw (lambda ()
                                       (gl-disable (enable-cap depth-test)))))

;;;
;;; Initialization
;;;

(start-sly-repl)

(add-hook! window-close-hook stop-game-loop)
;; (add-hook! draw-hook (lambda (dt alpha) (render)))

(with-window (make-window #:title "2048")
  (start-game-loop camera))

;;; Local Variables:
;;; compile-command: "../../pre-inst-env guile 2048"
;;; End: