379 lines
7.9 KiB
Scheme
379 lines
7.9 KiB
Scheme
(import (chicken random)
|
|
(engine core)
|
|
(engine math)
|
|
(engine components core)
|
|
(engine drawing)
|
|
(engine input)
|
|
(engine scene)
|
|
raylib
|
|
(srfi 1)
|
|
(srfi 99))
|
|
|
|
(register-event-bus 'turn-change)
|
|
|
|
(define draw-text-entities
|
|
(make-system
|
|
'draw-text
|
|
0
|
|
'entity
|
|
'(<visual-2d> <screen-transform>)
|
|
(lambda (_ vis-2d transform)
|
|
(let ((draw (visual-2d-draw vis-2d)))
|
|
(when (text-2d? draw)
|
|
(push-render-object 'screen
|
|
(visual-2d-layer vis-2d)
|
|
(lambda ()
|
|
(let ((draw-pos (v+ (position transform)
|
|
(text-2d-position draw))))
|
|
(draw-text-2d
|
|
draw-pos
|
|
(text-2d-text draw)
|
|
(text-2d-size draw)
|
|
(visual-2d-color vis-2d))))))))))
|
|
|
|
(define draw-rectangles
|
|
(make-system
|
|
'draw-rectangles
|
|
0
|
|
'entity
|
|
'(<visual-2d> <screen-transform>)
|
|
(lambda (_ vis-2d transform)
|
|
(let ((draw (visual-2d-draw vis-2d)))
|
|
(when (rectangle-2d? draw)
|
|
(push-render-object 'screen
|
|
(visual-2d-layer vis-2d)
|
|
(lambda ()
|
|
(let ((draw-pos (v+ (position transform)
|
|
(rectangle-2d-origin draw))))
|
|
(draw-rectangle-2d
|
|
draw-pos
|
|
(rectangle-2d-width draw)
|
|
(rectangle-2d-height draw)
|
|
(visual-2d-color vis-2d)
|
|
(rectangle-2d-filled? draw)
|
|
(rectangle-2d-thickness draw))))))))))
|
|
|
|
(register-action 'click 'mouse-press MOUSE_BUTTON_LEFT)
|
|
|
|
(define-record-type <button-region>
|
|
(make-button-region top-left bottom-right on-click)
|
|
button-region?
|
|
(top-left button-top-left)
|
|
(bottom-right button-bottom-right)
|
|
(on-click button-on-click))
|
|
|
|
(define click-buttons
|
|
(make-system
|
|
'click-buttons
|
|
1
|
|
'batch
|
|
'(<button-region> <screen-transform>)
|
|
(lambda (buttons)
|
|
(when (pop-event 'input 'click)
|
|
(for-each
|
|
(lambda (button)
|
|
(let* ((btn (find button-region? button))
|
|
(transform (find screen-transform? button))
|
|
(top-left (v+ (position transform)
|
|
(button-top-left btn)))
|
|
(bottom-right (v+ (position transform)
|
|
(button-bottom-right btn)))
|
|
(m-x (get-mouse-x))
|
|
(m-y (get-mouse-y)))
|
|
(when (and (< (v-x top-left) m-x (v-x bottom-right))
|
|
(< (v-y top-left) m-y (v-y bottom-right)))
|
|
((button-on-click btn)))))
|
|
buttons)))))
|
|
|
|
(define grid '((0 0 0)
|
|
(0 0 0)
|
|
(0 0 0)))
|
|
|
|
(define turn 'player) ;; Either 'player or 'bot
|
|
|
|
(define grid-square-size (vec 150 150))
|
|
|
|
(define (get-grid-value x y)
|
|
(list-ref (list-ref grid y) x))
|
|
|
|
(define (set-grid-value! x y val)
|
|
(set! (list-ref (list-ref grid y) x) val))
|
|
|
|
(define (game-complete?)
|
|
(or
|
|
(any (lambda (x) (and (not (= (car x) 0)) (apply = x))) grid)
|
|
(any (lambda (x) (and (not (= (car x) 0)) (apply = x)))
|
|
(list (map (lambda (x) (list-ref x 0)) grid)
|
|
(map (lambda (x) (list-ref x 1)) grid)
|
|
(map (lambda (x) (list-ref x 2)) grid)))
|
|
(and (not (= (get-grid-value 0 0) 0))
|
|
(= (get-grid-value 0 0)
|
|
(get-grid-value 1 1)
|
|
(get-grid-value 2 2)))
|
|
(and (not (= (get-grid-value 2 0) 0))
|
|
(= (get-grid-value 2 0)
|
|
(get-grid-value 1 1)
|
|
(get-grid-value 0 2)))
|
|
(every (lambda (x) (not (= 0 x)))
|
|
(flatten grid))))
|
|
|
|
(define (find-free-space)
|
|
(let* ((empty-spaces (filter
|
|
(lambda (x)
|
|
(= 0
|
|
(get-grid-value (car x)
|
|
(cdr x))))
|
|
(map
|
|
(lambda (x)
|
|
(cons (modulo x 3)
|
|
(floor (/ x 3))))
|
|
(iota 9)))))
|
|
(list-ref empty-spaces (pseudo-random-integer (length empty-spaces)))))
|
|
|
|
(define padding (vec 50 50))
|
|
|
|
(define draw-grid-squares
|
|
(make-system
|
|
'draw-grid-squares
|
|
0
|
|
'entity
|
|
'(<screen-transform> <grid-square>)
|
|
(lambda (_ transform sq)
|
|
(let ((check (list-ref (list-ref grid (g-y sq)) (g-x sq))))
|
|
(push-render-object 'screen
|
|
0
|
|
(lambda ()
|
|
(draw-text-2d
|
|
(v+ (v/ grid-square-size 4) (position transform))
|
|
(cond
|
|
((= check 1) "X")
|
|
((= check 2) "O")
|
|
(else ""))
|
|
64
|
|
(make-color 0 0 0 1))))))))
|
|
|
|
(define-record-type <grid-square>
|
|
(make-g-s x y)
|
|
grid-square?
|
|
(x g-x)
|
|
(y g-y))
|
|
|
|
(define-record-type <turn-display>
|
|
(make-turn-display)
|
|
turn-display?)
|
|
|
|
(define-record-type <turn>
|
|
(make-turn)
|
|
turn?)
|
|
|
|
(define-record-type <bot>
|
|
(make-bot)
|
|
bot?)
|
|
|
|
(define-record-type <timer>
|
|
(make-timer current max timeout done running)
|
|
timer?
|
|
(current timer-current set-timer-current!)
|
|
(max timer-max)
|
|
(timeout timer-timeout)
|
|
(done timer-done set-timer-done!)
|
|
(running timer-running set-timer-running!))
|
|
|
|
(define update-turn-display
|
|
(make-system
|
|
'update-turn-display
|
|
1
|
|
'entity
|
|
'(<visual-2d> <turn-display>)
|
|
(lambda (_ vis-2d _)
|
|
(let ((draw (visual-2d-draw vis-2d)))
|
|
(when (text-2d? draw)
|
|
(set-text-2d-text! draw
|
|
(case turn
|
|
((player) "Your Turn!")
|
|
((bot) "Bot Turn!")
|
|
((end) "Game over!")
|
|
(else "Whose turn is it anyway??"))))))))
|
|
|
|
(define check-game-state
|
|
(make-system
|
|
'check-game-state
|
|
0
|
|
'global
|
|
'()
|
|
(lambda ()
|
|
(when (game-complete?)
|
|
(set! turn 'end)))))
|
|
|
|
(define tick-timers
|
|
(make-system
|
|
'tick-timers
|
|
1
|
|
'entity
|
|
'(<timer>)
|
|
(lambda (_ timer)
|
|
(cond
|
|
((> (timer-current timer) (timer-max timer))
|
|
(set-timer-done! timer #t)
|
|
(set-timer-running! timer #f)
|
|
(set-timer-current! timer 0)
|
|
((timer-timeout timer)))
|
|
((timer-running timer)
|
|
(set-timer-current! timer
|
|
(+ (get-frame-time) (timer-current timer))))))))
|
|
|
|
(define toggle-bot
|
|
(make-system
|
|
'toggle-bot
|
|
1
|
|
'entity
|
|
'(<timer> <bot>)
|
|
(lambda (_ timer _)
|
|
(when (pop-event 'turn-change 'bot)
|
|
(set-timer-done! timer #f)
|
|
(set-timer-running! timer #t)))))
|
|
|
|
(define (make-grid-square x y)
|
|
(entity
|
|
(make-g-s x y)
|
|
(make-screen-transform
|
|
(v+ padding (v* (vec x y) grid-square-size))
|
|
(vec 0 0)
|
|
0
|
|
(vec 1 1)
|
|
'center
|
|
'())
|
|
(make-visual-2d
|
|
(make-rectangle-2d
|
|
(vec 0 0)
|
|
(v-x grid-square-size)
|
|
(v-y grid-square-size)
|
|
#f
|
|
10)
|
|
(make-color 0 0 0 1)
|
|
0)
|
|
(make-button-region
|
|
(vec 0 0)
|
|
grid-square-size
|
|
(lambda ()
|
|
(when (and (eqv? turn 'player) (= 0 (get-grid-value x y)))
|
|
(set-grid-value! x y 1)
|
|
(set! turn 'bot)
|
|
(push-event 'turn-change 'bot (make-turn)))))))
|
|
|
|
(define (game)
|
|
(scene
|
|
draw-rectangles
|
|
draw-text-entities
|
|
update-turn-display
|
|
draw-grid-squares
|
|
toggle-bot
|
|
click-buttons
|
|
tick-timers
|
|
push-actions
|
|
check-game-state
|
|
|
|
(entity
|
|
(make-turn-display)
|
|
(make-visual-2d
|
|
(make-text-2d
|
|
(vec 0 0)
|
|
"<turn>"
|
|
24)
|
|
(make-color 0 0 0 1)
|
|
0)
|
|
(make-screen-transform
|
|
(vec 550 150)
|
|
(vec 0 0)
|
|
0
|
|
(vec 1 1)
|
|
'center
|
|
'()))
|
|
|
|
(entity
|
|
(make-bot)
|
|
(make-timer
|
|
0
|
|
2
|
|
(lambda ()
|
|
(when
|
|
(let ((target (find-free-space)))
|
|
(set-grid-value! (car target) (cdr target) 2)
|
|
(set! turn 'player))))
|
|
#f
|
|
#f))
|
|
|
|
(make-grid-square 0 0)
|
|
(make-grid-square 1 0)
|
|
(make-grid-square 2 0)
|
|
(make-grid-square 0 1)
|
|
(make-grid-square 1 1)
|
|
(make-grid-square 2 1)
|
|
(make-grid-square 0 2)
|
|
(make-grid-square 1 2)
|
|
(make-grid-square 2 2)))
|
|
|
|
(define (main-menu)
|
|
(scene
|
|
draw-text-entities
|
|
click-buttons
|
|
draw-rectangles
|
|
push-actions
|
|
|
|
(entity
|
|
(make-screen-transform
|
|
(vec 350 250)
|
|
(vec 0 0)
|
|
0
|
|
(vec 1 1)
|
|
'center
|
|
'())
|
|
(make-visual-2d
|
|
(make-text-2d
|
|
(vec 0 0)
|
|
"Start Game!"
|
|
12)
|
|
(make-color 0 0 0 1)
|
|
0))
|
|
|
|
(entity
|
|
(make-button-region
|
|
(vec 0 0)
|
|
(vec 100 80)
|
|
(lambda ()
|
|
((game))))
|
|
(make-visual-2d
|
|
(make-rectangle-2d
|
|
(vec 0 0)
|
|
100
|
|
80
|
|
#t
|
|
1)
|
|
(make-color 1 0 0 1)
|
|
0)
|
|
(make-screen-transform
|
|
(vec 350 250)
|
|
(vec 0 0)
|
|
0
|
|
(vec 1 1)
|
|
'center
|
|
'()))
|
|
|
|
(entity
|
|
(make-visual-2d
|
|
(make-text-2d
|
|
(vec 0 0)
|
|
"Tic Tac Toe!"
|
|
48)
|
|
(make-color 0 0 0 1)
|
|
0)
|
|
(make-screen-transform
|
|
(vec 250 150)
|
|
(vec 0 0)
|
|
0
|
|
(vec 1 1)
|
|
'center
|
|
'()))))
|
|
|
|
((main-menu))
|
|
(create-window)
|