diff options
Diffstat (limited to 'examples/guile-2048')
| -rwxr-xr-x | examples/guile-2048/guile-2048 | 482 | ||||
| -rw-r--r-- | examples/guile-2048/tile.png | bin | 0 -> 585 bytes |
2 files changed, 482 insertions, 0 deletions
diff --git a/examples/guile-2048/guile-2048 b/examples/guile-2048/guile-2048 new file mode 100755 index 0000000..d5ded0a --- /dev/null +++ b/examples/guile-2048/guile-2048 @@ -0,0 +1,482 @@ +#! /usr/bin/env guile +!# + +;;; guile-2048 +;;; Copyright (C) 2014 David Thompson <dthompson2@worcester.edu> +;;; +;;; 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) + (2d audio) + (2d color) + (2d font) + (2d game) + (2d keyboard) + (2d rect) + (2d signal) + (2d sprite) + (2d texture) + (2d vector2) + (2d window) + (2d repl)) +;;; +;;; Helpers +;;; + +(define* (flat-map proc lst . rest) + (concatenate (apply map proc lst rest))) + +(define (enumerate lst) + (zip (iota (length lst)) lst)) + +;;; +;;; 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 lst) + (match lst + ((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))) + +;; So gross. +(define (board-insert board) + (let ((x (random board-size)) + (y (random board-size))) + (if (zero? (list-ref (list-ref board y) x)) + (append (take board y) + (let ((rows (drop board y))) + (cons (let ((cells (car rows))) + (append (take cells x) + (let ((rest (drop cells x))) + (cons (random-tile) + (cdr rest))))) + (cdr rows)))) + (board-insert board)))) + +(define (board-find board n) + (list? + (any (lambda (row) + (memq n row)) + board))) + +(define (board-win? board) + (board-find (make-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-sprites) +(enable-fonts) +(enable-audio) + +(define background (rgb #xfaf8ef)) + +(set-gl-clear-color (color-r background) + (color-g background) + (color-b background) + (color-a background)) + +(define tile-texture (load-texture "tile.png")) + +(define font (load-default-font 32)) + +(define-record-type <tile> + (%make-tile background label) + tile? + (background tile-background) + (label tile-label)) + +(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 x y n) + (let* ((w (texture-width tile-texture)) + (h (texture-height tile-texture)) + (background + (make-sprite tile-texture + #:position (center + (vector2 + (* x w) + (* y h))) + #:color (tile-bg-color n) + #:anchor null-vector2)) + (label + (make-label font + (if (zero? n) " " (number->string n)) + (center + (vector2 (+ (* x w) + (/ w 2)) + (+ (* y h) + (/ h 2)))) + #:color (tile-text-color n) + #:anchor 'center))) + (%make-tile background label))) + +(define (draw-tile tile) + (draw-sprite (tile-background tile)) + (draw-label (tile-label tile))) + +(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 + (vector2 (/ (- 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-signal status + (signal-map + (lambda (board) + (let ((message (cond ((board-lose? board) "GAME OVER") + ((board-win? board) "YOU WIN!") + (else "")))) + (make-label font message + (center + (vector2 (/ board-width 2) + (/ board-height 2))) + #:color black + #:anchor 'bottom-center))) + board)) + +(define play-again-font (load-default-font 16)) + +(define-signal play-again-message + (signal-map + (lambda (board) + (make-label play-again-font + (if (or (board-lose? board) + (board-win? board)) + "Press N to play again" + "") + (center + (vector2 (/ board-width 2) + (/ board-height 2))) + #:color black + #:anchor 'top-center)) + board)) + +(define instruction-font (load-default-font 16)) + +(define instructions + (make-label instruction-font + "Use the arrow keys to join the numbers and get to the 2048 tile!" + (vector2 (/ window-width 2) 0) + #:color text-color-1 + #:anchor 'top-center)) + +(define score-header-font (load-default-font 14)) +(define score-font (load-default-font 22)) + +(define score-header + (make-label score-header-font + "SCORE" + (vector2 (+ (vx center-pos) (/ board-width 4)) 24) + #:color text-color-1 + #:anchor 'top-center)) + +(define-signal score + (signal-map + (lambda (state) + (make-label score-font + (format #f "~d" (2048-score state)) + (vector2 (vx (label-position score-header)) + (+ (vy (label-position score-header)) 32)) + #:color text-color-1 + #:anchor 'center)) + 2048-state)) + +(define best-score-header + (make-label score-header-font + "BEST" + (vector2 (+ (vx center-pos) (- board-width (/ board-width 4))) 24) + #:color text-color-1 + #:anchor 'top-center)) + +(define-signal best-score + (signal-map + (lambda (state) + (make-label score-font + (format #f "~d" (2048-best-score state)) + (vector2 (vx (label-position best-score-header)) + (+ (vy (label-position best-score-header)) 32)) + #:color text-color-1 + #:anchor 'center)) + 2048-state)) + +(define (render) + (for-each draw-tile (signal-ref tiles)) + (draw-label instructions) + (draw-label score-header) + (draw-label best-score-header) + (draw-label (signal-ref score)) + (draw-label (signal-ref best-score)) + (draw-label (signal-ref status)) + (draw-label (signal-ref play-again-message))) + +;;; +;;; Initialization +;;; + +(start-2d-repl) + +(add-hook! window-close-hook quit-game) +(add-hook! draw-hook (lambda (dt alpha) (render))) + +(with-window (make-window #:title "2048") + (run-game-loop)) diff --git a/examples/guile-2048/tile.png b/examples/guile-2048/tile.png Binary files differnew file mode 100644 index 0000000..3d6f82c --- /dev/null +++ b/examples/guile-2048/tile.png |
