312 lines
9.8 KiB
Text
312 lines
9.8 KiB
Text
;;require-module (ice-9 format)
|
|
;;usage -> [~4d] <in> print-board
|
|
;;
|
|
(use-modules (ice-9 format))
|
|
|
|
;;require-module (srfi srfi-64)
|
|
;;usage -> test-assert
|
|
;;
|
|
(use-modules (srfi srfi-64))
|
|
|
|
;;prodedure-name 2or4-generator
|
|
;;input -> <$:nil>
|
|
;;output -> _ (number)
|
|
;;note -> "it only generates 2 or 4, with a 10% of outputting 4"
|
|
;;
|
|
(define 2or4-generator
|
|
(lambda ()
|
|
(let ([random-number (random 10)])
|
|
(if (zero? random-number)
|
|
4
|
|
2))))
|
|
|
|
;;procedure-name print-board
|
|
;;input -> board (array::4*4)
|
|
;;output -> <$:nil>
|
|
;;
|
|
(define print-board
|
|
(lambda (board)
|
|
(do ((i 0 (1+ i)))
|
|
((> i 3))
|
|
(do ((j 0 (1+ j)))
|
|
((> j 3))
|
|
(format #t "[~4d]" (array-ref board i j)))
|
|
(newline))))
|
|
|
|
;;procedure-name spawn!
|
|
;;input -> 4x4board (array::4*4)
|
|
;;output -> <$:nil>
|
|
;;
|
|
(define spawn!
|
|
(lambda (4x4board)
|
|
(let ([indexes '()])
|
|
(do ((i 0 (1+ i)))
|
|
((> i 3))
|
|
(do ((j 0 (1+ j)))
|
|
((> j 3))
|
|
(when (zero? (array-ref 4x4board i j))
|
|
(set! indexes (cons (cons i j) indexes)))))
|
|
(let* ([indexes-length (length indexes)]
|
|
[used-index-index (random indexes-length)]
|
|
[used-index-pair (list-ref indexes used-index-index)])
|
|
(array-set! 4x4board (2or4-generator) (car used-index-pair) (cdr used-index-pair))))))
|
|
|
|
;;procedure-name ask-user
|
|
;;input -> valid-moves (list:symbol)
|
|
;;output -> _ (symbol) [(memq <$:self:_> (list 'up 'down 'left 'right)) => #t]
|
|
;;note -> "this procedure assumes there is at least one valid move"
|
|
;;
|
|
(define ask-user
|
|
(lambda (valid-moves)
|
|
(let loop ()
|
|
(let ([option (read)])
|
|
(if (memq option valid-moves)
|
|
(case option
|
|
[(up) 'up]
|
|
[(down) 'down]
|
|
[(left) 'left]
|
|
[(right) 'right]
|
|
[else (begin
|
|
(display "wrong input! Please type up, down, left, or right only!")
|
|
(newline)
|
|
(loop))])
|
|
(begin
|
|
(display "please use valid moves!")
|
|
(newline)
|
|
(display "valid moves: ")
|
|
(display valid-moves)
|
|
(newline)
|
|
(loop)))))))
|
|
|
|
;;procedure-name update-row!
|
|
;;input -> row (array::1*4)
|
|
;;output -> <$:nil>
|
|
;;
|
|
(define update-row!
|
|
(lambda (row)
|
|
(unless (array-equal? row #(0 0 0 0))
|
|
(let ([lst '()] [l 0])
|
|
(when (not (zero? (array-ref row 3))) (set! l (1+ l)) (set! lst (cons (array-ref row 3) lst)))
|
|
(when (not (zero? (array-ref row 2))) (set! l (1+ l)) (set! lst (cons (array-ref row 2) lst)))
|
|
(when (not (zero? (array-ref row 1))) (set! l (1+ l)) (set! lst (cons (array-ref row 1) lst)))
|
|
(when (not (zero? (array-ref row 0))) (set! l (1+ l)) (set! lst (cons (array-ref row 0) lst)))
|
|
(do ((i 0 (1+ i)))
|
|
((>= i (- 4 l)))
|
|
(array-set! row 0 i))
|
|
(do ((i (- 4 l) (1+ i)) (j 0 (1+ j)))
|
|
((>= i 4))
|
|
(array-set! row (list-ref lst j) i)))
|
|
(if (= (array-ref row 3) (array-ref row 2))
|
|
(begin (array-set! row (+ (array-ref row 3) (array-ref row 2)) 3)
|
|
(array-set! row (array-ref row 1) 2)
|
|
(array-set! row (array-ref row 0) 1)
|
|
(array-set! row 0 0)
|
|
(when (= (array-ref row 2) (array-ref row 1))
|
|
(array-set! row (+ (array-ref row 2) (array-ref row 1)) 2)
|
|
(array-set! row 0 1)))
|
|
(if (= (array-ref row 2) (array-ref row 1))
|
|
(begin (array-set! row (+ (array-ref row 2) (array-ref row 1)) 2)
|
|
(array-set! row (array-ref row 0) 1)
|
|
(array-set! row 0 0))
|
|
(when (= (array-ref row 1) (array-ref row 0))
|
|
(array-set! row (+ (array-ref row 1) (array-ref row 0)) 1)
|
|
(array-set! row 0 0)))))))
|
|
|
|
;;procedure-name update-board!
|
|
;;input -> board (array::4*4)
|
|
;;output -> <$:nil>
|
|
;;note -> "this procedure can assume that the opertion is shifting the piles right"
|
|
;;
|
|
(define update-board!
|
|
(lambda (board)
|
|
(do ((i 0 (1+ i)))
|
|
((>= i 4))
|
|
(update-row! (array-cell-ref board i)))))
|
|
|
|
;;procedure-name row-can-shift-qright?
|
|
;;input -> row (array::1*4)
|
|
;;output -> _ (#t or #f)
|
|
;;
|
|
(define row-can-shift-right?
|
|
(lambda (row)
|
|
(if (and (zero? (array-ref row 0))
|
|
(zero? (array-ref row 1))
|
|
(zero? (array-ref row 2)))
|
|
#f
|
|
(if (or (zero? (array-ref row 3))
|
|
(and (not (zero? (array-ref row 0))) (member 0 (list
|
|
(array-ref row 1)
|
|
(array-ref row 2)
|
|
(array-ref row 3))))
|
|
(and (not (zero? (array-ref row 1))) (member 0 (list
|
|
(array-ref row 2)
|
|
(array-ref row 3))))
|
|
(and (not (zero? (array-ref row 2))) (member 0 (list
|
|
(array-ref row 3)))))
|
|
#t
|
|
(if (or (and (not (zero? (array-ref row 0))) (= (array-ref row 0) (array-ref row 1)))
|
|
(and (not (zero? (array-ref row 1))) (= (array-ref row 1) (array-ref row 2)))
|
|
(and (not (zero? (array-ref row 2))) (= (array-ref row 2) (array-ref row 3))))
|
|
#t
|
|
#f)))))
|
|
|
|
(define test-row-can-shift-right?
|
|
(lambda ()
|
|
(test-begin "row-can-shift-right? test")
|
|
(test-assert (row-can-shift-right? #(2 0 0 0)))
|
|
(test-assert (row-can-shift-right? #(0 2 0 0)))
|
|
(test-assert (row-can-shift-right? #(0 0 2 0)))
|
|
(test-assert (not (row-can-shift-right? #(0 0 0 2))))
|
|
(test-assert (row-can-shift-right? #(4 2 0 0)))
|
|
(test-assert (row-can-shift-right? #(2 0 0 2)))
|
|
(test-assert (row-can-shift-right? #(1024 8 2 2)))
|
|
(test-end "row-can-shift-right? test")))
|
|
|
|
;;procedure-name can-shift-right?
|
|
;;input -> board (array::4*4)
|
|
;;output -> _ (#t or #f)
|
|
;;
|
|
(define can-shift-right?
|
|
(lambda (board)
|
|
(or (row-can-shift-right? (array-cell-ref board 0))
|
|
(row-can-shift-right? (array-cell-ref board 1))
|
|
(row-can-shift-right? (array-cell-ref board 2))
|
|
(row-can-shift-right? (array-cell-ref board 3)))))
|
|
|
|
(define test-can-shift-right?
|
|
(lambda ()
|
|
(test-begin "can-shift-right? test")
|
|
(test-assert (can-shift-right? #2((2 0 0 2)
|
|
(0 0 0 0)
|
|
(0 0 0 0)
|
|
(0 0 0 0))))
|
|
(test-assert (can-shift-right? #2((2 0 0 0)
|
|
(0 0 0 0)
|
|
(0 0 0 0)
|
|
(2 0 0 0))))
|
|
(test-assert (not (can-shift-right? #2((2 8 4 8)
|
|
(2 16 4 8)
|
|
(0 0 0 4)
|
|
(0 0 0 2)))))
|
|
(test-end "can-shift-right? test")))
|
|
|
|
;;procedure-name valid-move?
|
|
;;input -> board (array::4*4)
|
|
;;output -> _ (symbol) [(eq? 'gameover <$:self:_>) => #t]
|
|
;;output -> _ (list:symbol[1 or 2 or 3 or 4])
|
|
;;note -> "the list symbol should only contain up, down, left, right"
|
|
;;
|
|
(define valid-move?
|
|
(lambda (board)
|
|
(let* ([output-lst '()]
|
|
[rows board]
|
|
[columns (make-shared-array rows
|
|
(lambda (i j)
|
|
(list j i))
|
|
4 4)]
|
|
[rows-reversed (make-shared-array rows
|
|
(lambda (i j)
|
|
(list i (- 3 j)))
|
|
4 4)]
|
|
[columns-reversed (make-shared-array columns
|
|
(lambda (i j)
|
|
(list i (- 3 j)))
|
|
4 4)])
|
|
(when (can-shift-right? rows) (set! output-lst (append (list 'right) output-lst)))
|
|
(when (can-shift-right? rows-reversed) (set! output-lst (append (list 'left) output-lst)))
|
|
(when (can-shift-right? columns) (set! output-lst (append (list 'down) output-lst)))
|
|
(when (can-shift-right? columns-reversed) (set! output-lst (append (list 'up) output-lst)))
|
|
(if (null? output-lst)
|
|
'gameover
|
|
output-lst))))
|
|
|
|
(define test-valid-move?
|
|
(lambda ()
|
|
(test-begin "valid-move? test")
|
|
(test-assert (eq? 'gameover (valid-move? #2((8 4 2 16)
|
|
(2 8 4 32)
|
|
(4 2 8 16)
|
|
(128 4 16 64)))))
|
|
(test-assert (equal? (list 'up 'down 'left 'right) (valid-move? #2((0 0 0 0)
|
|
(0 2 0 0)
|
|
(0 0 0 0)
|
|
(0 0 0 2)))))
|
|
(test-end "valid-move? test")))
|
|
|
|
;;prodedure-name check-game-status!
|
|
;;input -> board (array::4*4)
|
|
;;output -> _ (symbol)
|
|
;;note -> "The thing this procedure should implement: 1.decide whether there is a 2048 tile on board, if so, return 'win 2.decide the valid moves next time and return them as a list like (list 'up 'down 'right) or anything equivalent (if there is no valid moves, just return 'gameover)"
|
|
;;
|
|
(define check-game-status!
|
|
(lambda (board)
|
|
(spawn! board)
|
|
(let ([all-tiles (list (array-ref board 0 0)
|
|
(array-ref board 0 1)
|
|
(array-ref board 0 2)
|
|
(array-ref board 0 3)
|
|
(array-ref board 1 0)
|
|
(array-ref board 1 1)
|
|
(array-ref board 1 2)
|
|
(array-ref board 1 3)
|
|
(array-ref board 2 0)
|
|
(array-ref board 2 1)
|
|
(array-ref board 2 2)
|
|
(array-ref board 2 3)
|
|
(array-ref board 3 0)
|
|
(array-ref board 3 1)
|
|
(array-ref board 3 2)
|
|
(array-ref board 3 3))])
|
|
(if (member 2048 all-tiles)
|
|
'win
|
|
(valid-move? board)))))
|
|
|
|
;;procedure-name play
|
|
;;input -> <$:nil>
|
|
;;output -> _ (array:4*4)
|
|
;;
|
|
(define play
|
|
(lambda ()
|
|
(set! *random-state* (random-state-from-platform))
|
|
(let ([board (make-array 0 4 4)])
|
|
(let* ([rows board]
|
|
[columns (make-shared-array rows
|
|
(lambda (i j)
|
|
(list j i))
|
|
4 4)]
|
|
[rows-reversed (make-shared-array rows
|
|
(lambda (i j)
|
|
(list i (- 3 j)))
|
|
4 4)]
|
|
[columns-reversed (make-shared-array columns
|
|
(lambda (i j)
|
|
(list i (- 3 j)))
|
|
4 4)])
|
|
(spawn! rows)
|
|
(let loop ([turn 1] [available-moves (valid-move? rows)])
|
|
(format #t "TURN ~d" turn)
|
|
(newline)
|
|
(print-board rows)
|
|
(case (ask-user available-moves)
|
|
[(up) (update-board! columns-reversed)]
|
|
[(down) (update-board! columns)]
|
|
[(left) (update-board! rows-reversed)]
|
|
[(right) (update-board! rows)]
|
|
[else (error "something went wrong! The return stuff from (ask-user availuable-moves) is not among 'up 'down 'left 'right! This <else> normally should never be reached.")])
|
|
(let ([symbols (check-game-status! rows)])
|
|
(cond
|
|
[(symbol? symbols) (case symbols
|
|
[(win) (begin
|
|
(display "You win!")
|
|
(newline)
|
|
(print-board rows))]
|
|
[(gameover) (begin
|
|
(display "You lose!")
|
|
(newline)
|
|
(print-board rows))]
|
|
[else (error "While not intended, we named what the procedure (check-game-status rows) returned as symbols, checking it as a symbol which passed, then we get this. But we coded this to be 'win or 'gameover !")])]
|
|
[(list? symbols) (begin
|
|
(display "Valid moves: ")
|
|
(display symbols)
|
|
(newline)
|
|
(loop (1+ turn) symbols))])))))))
|