path: root/examples/2048/2048.scm

;;; 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)
             (ice-9 match)
             (sly utils)
             (sly math)
             (sly math rect)
             (sly math transform)
             (sly math tween)
             (sly math vector)
             (sly render)
             (sly render camera)
             (sly render color)
             (sly render font)
             (sly render sprite)
             (sly render texture)
             (sly input keyboard)
             (sly game)
             (sly signal)
             (sly window)
             (sly audio)
             (sly repl))

(set! *random-state* (random-state-from-platform))

;;;
;;; Helpers
;;;

(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-down board)
  (let-values (((points board)
                (unzip2 (board-shift-left (transpose board)))))
    (zip points (transpose board))))

(define (board-shift-up 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-append (getenv "HOME") "/.guile-2048"))

(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 (read)))
            (if (number? score) score 0))))
      0))

(define (save-best-score state)
  (with-output-to-file save-file
    (lambda ()
      (write (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))

(add-signal-hook! 2048-state
  (lambda (state)
    (when (board-lose? (2048-board state))
      (save-best-score state))))

(define-signal same-score?
  (signal-let ((current 2048-state)
               (prev (signal-delay 1 2048-state)))
    (= (2048-score prev)
       (2048-score current))))

;;;
;;; Rendering
;;;

(define (maybe-play-sample sample)
  (and sample (play-sample sample)))

(define background (rgb #xfaf8ef))

(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 (make-tile-label-cache font)
  (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 (render-tile tile-texture tile-sprite tile-label-cache x y n)
  (let ((w (texture-width tile-texture))
        (h (texture-height tile-texture))
        (label (assoc-ref tile-label-cache n))
        (label-color (tile-text-color n))
        (bg-color (tile-bg-color n)))
    (move (vector2 (* x w) (* y h))
          (render-begin
           (with-color bg-color
             (render-sprite tile-sprite))
           (if (zero? n)
               render-nothing
               (with-color label-color
                 (move (vector2 (/ w 2) (/ h 2))
                       (render-sprite label))))))))

(define window-width 640)
(define window-height 480)

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

(define (render-board board tile-texture tile-sprite tile-label-cache)
  (list->renderer
   (append-map
    (match-lambda
     ((y (row ...))
      (map (match-lambda
            ((x n)
             (render-tile tile-texture tile-sprite tile-label-cache x y n)))
           row)))
    (enumerate-board board))))

(define (render-label font text anchor)
  (with-color black
    (render-sprite
     (make-label font text #:anchor anchor))))

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

(define (score-label text score x)
  (let* ((duration 15)
         (position-tween (let* ((to (vector2 0 -32))
                                (from (v- to (vector2 0 -8))))
                           (tween vlerp ease-linear from to duration)))
         (color-tween (tween color-lerp ease-linear
                             transparent text-color-1 duration)))
    (signal-let* ((score-font score-font)
                  (x x)
                  (header (render-label-maybe score-header-font
                                              text
                                              'top-center))
                  (score (signal-drop-repeats score))
                  (timer (signal-drop (lambda (t) (> t duration))
                                      0 (signal-since 1 score))))
      (if (and score-font header x)
          (let ((score (make-label score-font (number->string score)
                                   #:anchor 'center)))
            (move (vector2 x (- window-height 28))
                  (render-begin
                   (with-color text-color-1 header)
                   (move (position-tween timer)
                         (with-color (color-tween timer)
                           (render-sprite score))))))
          render-nothing))))

(define camera
  (2d-camera #:area (make-rect 0 0 640 480) #:clear-color background))

(define* (render-label-maybe font message anchor)
  (signal-map-maybe (lambda (font)
                      (render-label font message anchor))
                    font))

(define-signal tile-texture
  (on-start (load-texture "tile.png")))

(define-signal board-width
  (signal-map-maybe (lambda (tile-texture)
                      (* board-size (texture-width tile-texture)))
                    tile-texture))

(define-signal board-height
  (signal-map-maybe (lambda (tile-texture)
                      (* board-size (texture-height tile-texture)))
                    tile-texture))

(define-signal center-pos
  (signal-map-maybe (lambda (board-width)
                      (vector2 (/ (- window-width board-width) 2) 8))
                    board-width))

(define-signal score-unchanged-sound
  (on-start (load-sample "../sounds/hit.wav")))

(define-signal score-changed-sound
  (on-start (load-sample "../sounds/jump.wav")))

(define-signal sound-effect
  (signal-map-maybe (cut if <> <> <>)
                    same-score?
                    score-unchanged-sound
                    score-changed-sound))

(define-signal font
  (on-start (load-default-font 32)))

(define-signal tile-sprite
  (signal-map-maybe (cut make-sprite <> #:anchor (vector2 0 0))
                    tile-texture))

(define-signal tile-label-cache
  (signal-map-maybe make-tile-label-cache font))

(define-signal tiles
  (signal-map-maybe render-board
                    board
                    tile-texture
                    tile-sprite
                    tile-label-cache))

(define-signal instruction-font
  (on-start (load-default-font 16)))

(define-signal play-again-font
  (on-start (load-default-font 16)))

(define-signal score-header-font
  (on-start (load-default-font 14)))

(define-signal score-font
  (on-start (load-default-font 22)))

(define-signal status-message
  (signal-let ((board board)
               (play-again (render-label-maybe play-again-font
                                               "Press N to play again"
                                               'top-center))
               (game-over  (render-label-maybe font "GAME OVER" 'bottom-center))
               (you-win    (render-label-maybe font "YOU WIN!" 'bottom-center))
               (board-width board-width)
               (board-height board-height))
    (let ((message (cond
                    ((board-lose? board) game-over)
                    ((board-win? board) you-win)
                    (else #f))))
      (if message
          (move (vector2 (/ board-width 2)
                         (/ board-height 2))
                (render-begin message play-again))
          render-nothing))))

(define-signal score
  (score-label "SCORE"
               (signal-map 2048-score 2048-state)
               (signal-map-maybe (cut / <> 4) board-width)))

(define-signal best-score
  (score-label "BEST"
               (signal-map 2048-best-score 2048-state)
               (signal-map-maybe (lambda (width)
                                   (- width (/ width 4)))
                                 board-width)))

(define-signal instructions
  (signal-map-maybe (lambda (board-width center-pos instruction-font)
                      (with-color text-color-1
                        (move (vector2 (/ board-width 2)
                                       (- window-height (vy center-pos)))
                              (render-sprite
                               (make-label instruction-font instruction-text
                                           #:anchor 'top-center)))))
                    board-width
                    center-pos
                    instruction-font))

(define-signal 2048-view
  (signal-map-maybe (lambda (center . renderers)
                      (move center (list->renderer renderers)))
                    center-pos
                    instructions
                    tiles
                    score
                    best-score
                    status-message))

(define-signal 2048-scene
  (signal-let ((view 2048-view))
    (with-camera camera (or view render-nothing))))

;;;
;;; Initialization
;;;

;; (start-sly-repl)

(add-signal-hook! sound-effect maybe-play-sample)
(add-hook! window-close-hook stop-game-loop)

(with-window (make-window #:title "2048")
  (enable-fonts)
  (enable-audio)
  (run-game-loop 2048-scene))

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