368 lines
17 KiB
Scheme
368 lines
17 KiB
Scheme
;; -*- geiser-scheme: chicken -*-
|
|
(module board
|
|
*
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken random)
|
|
(chicken plist)
|
|
miscmacros
|
|
srfi-1
|
|
srfi-123
|
|
mini-kanren
|
|
uuid
|
|
(prefix sdl2 "sdl2:")
|
|
(prefix sdl2-image "img:")
|
|
(prefix sdl2-ttf "ttf:"))
|
|
|
|
(ttf:init!)
|
|
|
|
(define logo-font (ttf:open-font "resources/ui/SourceSerifPro-Regular.otf" 80))
|
|
|
|
|
|
(define background #f)
|
|
(define house #f)
|
|
(define flower #f)
|
|
(define dicesym #f)
|
|
(define flower-rotation 0)
|
|
(define player-offset '((1 400 . 250)
|
|
(2 400 . 835)))
|
|
|
|
(define tiles #f)
|
|
|
|
(define white-bottom #f)
|
|
(define white-top #f)
|
|
(define black-bottom #f)
|
|
(define black-top #f)
|
|
|
|
(define state #f)
|
|
|
|
(define orig-board
|
|
'(;; Torso
|
|
((0 . 0) . flower:)
|
|
((0 . 1) . gate:)
|
|
((0 . 2) . flower:)
|
|
((1 . 0) . temple:)
|
|
((1 . 1) . water:)
|
|
((1 . 2) . temple:)
|
|
((2 . 0) . water:)
|
|
((2 . 1) . market:)
|
|
((2 . 2) . water:)
|
|
((3 . 0) . temple:)
|
|
((3 . 1) . flower:)
|
|
((3 . 2) . temple:)
|
|
;; Neck
|
|
((4 . 1) . water:)
|
|
((5 . 1) . market:)
|
|
;; Head
|
|
((6 . 0) . flower:)
|
|
((6 . 1) . temple:)
|
|
((6 . 2) . flower:)
|
|
((7 . 0) . treasury:)
|
|
((7 . 1) . water:)
|
|
((7 . 2) . treasury:)))
|
|
|
|
(define player-paths
|
|
'((1 . ((1 . (3 . 0))
|
|
(2 . (2 . 0))
|
|
(3 . (1 . 0))
|
|
(4 . (0 . 0))
|
|
(5 . (0 . 1))
|
|
(6 . (1 . 1))
|
|
(7 . (2 . 1))
|
|
(8 . (3 . 1))
|
|
(9 . (4 . 1))
|
|
(10 . (5 . 1))
|
|
(11 . (6 . 1))
|
|
(12 . (7 . 1))
|
|
(13 . (7 . 0))
|
|
(14 . (6 . 0))
|
|
(15 . (5 . 0))))
|
|
(2 . ((1 . (3 . 2))
|
|
(2 . (2 . 2))
|
|
(3 . (1 . 2))
|
|
(4 . (0 . 2))
|
|
(5 . (0 . 1))
|
|
(6 . (1 . 1))
|
|
(7 . (2 . 1))
|
|
(8 . (3 . 1))
|
|
(9 . (4 . 1))
|
|
(10 . (5 . 1))
|
|
(11 . (6 . 1))
|
|
(12 . (7 . 1))
|
|
(13 . (7 . 2))
|
|
(14 . (6 . 2))
|
|
(15 . (5 . 2))))))
|
|
|
|
(define (grid-rect x y)
|
|
(sdl2:make-rect (+ 500 (* x 120))
|
|
(+ 400 (* y 120))
|
|
120 120))
|
|
|
|
(define (init-piece player id)
|
|
(let ((coords (sdl2:make-rect (+ (car (alist-ref player player-offset)) (* id 100))
|
|
(cdr (alist-ref player player-offset)) 75 75)))
|
|
`((uuid: . ,(uuid))
|
|
(player: . ,player)
|
|
(state: . top:)
|
|
(initial-coords: . ,coords)
|
|
(coords: . ,coords)
|
|
(target-coords: . ,coords)
|
|
(step: . 0))))
|
|
|
|
(define (initialize-state!)
|
|
(set! state
|
|
`((active-player: . 1)
|
|
(phase: . roll-dice:)
|
|
(players: . ((1 . ((type: . local:)
|
|
(piece-y-offset: . -10)))
|
|
(2 . ((type: . local:)
|
|
(piece-y-offset: . 10)))))
|
|
(pieces: . (,(init-piece 1 0)
|
|
,(init-piece 1 1)
|
|
,(init-piece 1 2)
|
|
,(init-piece 1 3)
|
|
,(init-piece 1 4)
|
|
,(init-piece 1 5)
|
|
,(init-piece 1 6)
|
|
,(init-piece 2 0)
|
|
,(init-piece 2 1)
|
|
,(init-piece 2 2)
|
|
,(init-piece 2 3)
|
|
,(init-piece 2 4)
|
|
,(init-piece 2 5)
|
|
,(init-piece 2 6))))))
|
|
|
|
(define (update-state! player kw)
|
|
(set-cdr! (alist-ref player (alist-ref players: state) state) kw))
|
|
|
|
(define (refo coll key val)
|
|
(membero (cons key val) coll))
|
|
|
|
(define (commando out key val)
|
|
(membero (cons key val) out))
|
|
|
|
(define (field coords type)
|
|
(membero (cons coords type) orig-board))
|
|
|
|
;; When given a piece, returns its board x y position.
|
|
;; When given a board position, returns the piece.
|
|
(define (piece-pos piece pos)
|
|
(fresh (player piece-step player-path) ; Initialize empty variables
|
|
(membero piece (cdr (assoc pieces: state))) ; The piece is a member of the state alist
|
|
(refo piece player: player) ; The player number is under key "player:" in the piece alist.
|
|
(refo piece step: piece-step) ; The piece step is under key "step:" in the piece alist.
|
|
(refo player-paths player player-path) ; The player-path is under the player number in the "player-paths" alist
|
|
(=/= piece-step 0) ; The piece step cannot be 0
|
|
(refo player-path piece-step pos))) ; The position is under piece-step in the "player-path" alist.
|
|
|
|
;; Given a piece and a diceroll, returns the board x y position
|
|
;; the piece will have to move to.
|
|
(define (piece-targetpos piece dice out)
|
|
(fresh (player piece-step piece-targetstep player-path) ; Initialize empty variables
|
|
(membero piece (cdr (assoc pieces: state))) ; The piece is a member of the state alist
|
|
(refo piece player: player) ; The player number is the value of the piece entry with key "player:"
|
|
(refo piece step: piece-step) ; The step number is the value of the piece entry with key "step:"
|
|
(numbero piece-step) ; piece-step is a number
|
|
(refo player-paths player player-path) ; The played piece path is the value of the player-paths entry with key player
|
|
(refo player-path piece-targetstep out) ; Set "out" to the player-path entry found under key piece-targetstep
|
|
(project (piece-step) ; Turn piece-step from a logic variable into a usable value...
|
|
(== (+ piece-step dice) piece-targetstep)))) ; and set piece-targetstep to the sum of piece-step plus the dice value
|
|
|
|
;; Given a piece and a dice value, returns the actions to be performed on the board.
|
|
(define (check-move piece dice out)
|
|
(fresh (player piece-uuid target-uuid newpiece-pos target-player target-piece)
|
|
(refo piece player: player)
|
|
(refo piece uuid: piece-uuid)
|
|
(listo out)
|
|
(conda ((piece-targetpos piece dice newpiece-pos) ; Given the target would be on the board
|
|
(conda ; v Subconditions
|
|
((piece-pos target-piece newpiece-pos) ; | Given there is a piece on the target house
|
|
(conda ((refo target-piece player: player) ; | It's the player's faction
|
|
(commando out block: #t)) ; | | => Deny the movement
|
|
((refo target-piece uuid: target-uuid) ; | It's the enemy faction
|
|
(conda ((field newpiece-pos flower:) ; | | Given the piece would end up on flower
|
|
(commando out block: #t)) ; | | | => Deny the movement
|
|
; | | Else: yeet the piece back to start
|
|
((commando out reset: target-uuid) ; | | | => Reset the enemy piece
|
|
(commando out move: piece-uuid)))))) ; | | | => Move the player piece
|
|
; | Else: The target house is clear
|
|
((conda ((field newpiece-pos flower:) ; | | Given the piece would end up on flower
|
|
(commando out move: piece-uuid) ; | | | => Move the piece
|
|
(commando out phase: roll-dice:)) ; | | | => Set the state to the dice reroll
|
|
((commando out move: piece-uuid) ; | | Else: move the piece
|
|
(commando out switch-player: #t)
|
|
(commando out phase: roll-dice:)))))) ; | => Move the player piece
|
|
; Else: Target would be off board
|
|
((commando out block: #t))))) ; | => Deny the movement
|
|
|
|
(define (check-can-player-move player dice out)
|
|
(fresh (piece commands) ; Initialize empty variables
|
|
(membero piece (cdr (assoc pieces: state))) ; The piece is a member of the state list
|
|
(refo piece player: player) ; It belongs to the active player
|
|
(check-move piece dice commands) ; Determine of the piece can move given the dice roll
|
|
(conda ((membero (cons block: #t) commands) ; Given the call to "check-move" returns a blocking command
|
|
(== out #f)) ; | Return false
|
|
((== out #t))))) ; Else: return true
|
|
|
|
(define (load-texture renderer file)
|
|
(sdl2:create-texture-from-surface renderer (img:load file)))
|
|
|
|
(define (prepare! renderer)
|
|
(set! flower (load-texture renderer "resources/tiles/flower.png"))
|
|
(set! dicesym (load-texture renderer "resources/sprites/die0.png"))
|
|
(set! tiles
|
|
`((flower: . ,(load-texture renderer "resources/tiles/flower.png"))
|
|
(gate: . ,(load-texture renderer "resources/tiles/gate.png"))
|
|
(water: . ,(load-texture renderer "resources/tiles/water.png"))
|
|
(temple: . ,(load-texture renderer "resources/tiles/temple.png"))
|
|
(treasury: . ,(load-texture renderer "resources/tiles/treasury.png"))
|
|
(market: . ,(load-texture renderer "resources/tiles/market.png"))))
|
|
(set! background (load-texture renderer "resources/ui/gate.jpeg"))
|
|
(set! house (load-texture renderer "resources/tiles/house.png"))
|
|
|
|
(set! white-bottom (load-texture renderer "resources/sprites/piece-white-bottom.png"))
|
|
(set! white-top (load-texture renderer "resources/sprites/piece-white-top.png"))
|
|
(set! black-bottom (load-texture renderer "resources/sprites/piece-black-bottom.png"))
|
|
(set! black-top (load-texture renderer "resources/sprites/piece-black-top.png"))
|
|
(initialize-state!)
|
|
#f)
|
|
|
|
(define (find-piece-for-uuid uuid)
|
|
(find (lambda (piece)
|
|
(eq? uuid (alist-ref uuid: piece)))
|
|
(alist-ref pieces: state)))
|
|
|
|
(define (reset-piece! piece-uuid)
|
|
(let ((piece (find-piece-for-uuid piece-uuid)))
|
|
(print "Reset piece " piece)
|
|
(set-cdr! (assoc step: piece) 0)
|
|
(set-cdr! (assoc coords: piece) (alist-ref initial-coords: piece))))
|
|
|
|
(define (move-piece! piece-uuid steps)
|
|
(let ((piece (find-piece-for-uuid piece-uuid)))
|
|
(print "Move piece " piece)
|
|
(let* ((active-player (alist-ref active-player: state))
|
|
(players (alist-ref players: state))
|
|
(player (alist-ref active-player players))
|
|
(piece-y-offset (alist-ref piece-y-offset: player))
|
|
(new-step (if (< (alist-ref step: piece) 15)
|
|
(+ steps (alist-ref step: piece))
|
|
(alist-ref step: piece)))
|
|
(player-path (alist-ref active-player player-paths))
|
|
(coords (alist-ref new-step player-path))
|
|
(rect (grid-rect (car coords) (cdr coords))))
|
|
(set! (sdl2:rect-x rect) (+ (sdl2:rect-x rect) 20))
|
|
(set! (sdl2:rect-y rect) (+ (sdl2:rect-y rect) 20 piece-y-offset))
|
|
(set! (sdl2:rect-w rect) 75)
|
|
(set! (sdl2:rect-h rect) 75)
|
|
(set-cdr! (assoc step: piece) new-step)
|
|
(set-cdr! (assoc coords: piece) rect)
|
|
(set-cdr! (assoc active-player: state) (if (eq? 1 active-player) 2 1)))))
|
|
|
|
(define (check-piececlick)
|
|
(let/cc break
|
|
(let* ((active-player (alist-ref active-player: state))
|
|
(player-state (alist-ref state: (alist-ref active-player (alist-ref players: state))))
|
|
(nonsense (print "Player state:" player-state))
|
|
(piece (find (lambda (x)
|
|
(and (sdl2:point-in-rect? (get 'sdlprops 'mouse-point) (alist-ref coords: x))
|
|
(eq? (alist-ref player: x) active-player)))
|
|
(alist-ref pieces: state)))
|
|
(piece (if (eqv? #f piece) (break #t) piece)) ;; Jump out if no piece clicked.
|
|
(pos (alist-ref step: piece))
|
|
(dice 1)
|
|
(instructions (car (run 1 (q) (check-move piece dice q)))))
|
|
(for-each
|
|
(lambda (instruction)
|
|
(let ((inst (car instruction))
|
|
(arg (cdr instruction)))
|
|
(case inst
|
|
((block:) #t)
|
|
((reset:) (reset-piece! arg))
|
|
((move:) (move-piece! arg dice)))))
|
|
instructions))))
|
|
|
|
(define (handle-event ev)
|
|
(case (sdl2:event-type ev)
|
|
((mouse-button-up)
|
|
(check-piececlick))))
|
|
|
|
(define (update-scene!)
|
|
(set! flower-rotation (modulo (ceiling (/ (get 'sdlprops 'ticks) 50))
|
|
360))
|
|
#f)
|
|
|
|
(define (render-logo! window)
|
|
(let*-values (((text-w text-h) (ttf:size-utf8 logo-font "The Royal Game of Ur")))
|
|
(sdl2:render-copy-ex! window flower
|
|
#f (sdl2:make-rect 50 50 100 100) flower-rotation)
|
|
(sdl2:render-copy-ex! window flower
|
|
#f (sdl2:make-rect 1770 50 100 100) flower-rotation)
|
|
(sdl2:render-copy! window
|
|
(sdl2:create-texture-from-surface window
|
|
(ttf:render-utf8-blended logo-font "The Royal Game of Ur" (sdl2:make-color 0 0 0)))
|
|
#f (sdl2:make-rect (- (/ 1920 2) (/ text-w 2)) 10 text-w text-h))
|
|
))
|
|
|
|
(define (render-field! renderer type x y)
|
|
(let* ((rect (grid-rect x y))
|
|
(tilerect (sdl2:make-rect (+ 10 (sdl2:rect-x rect))
|
|
(+ 10 (sdl2:rect-y rect))
|
|
100 100)))
|
|
(sdl2:render-copy! renderer house #f rect)
|
|
(sdl2:render-copy! renderer (alist-ref type tiles) #f tilerect)))
|
|
|
|
(define (render-dice! renderer)
|
|
(sdl2:render-copy! renderer dicesym #f (sdl2:make-rect 1600 700 75 75)))
|
|
|
|
(define (draw-orig-board! renderer)
|
|
(sdl2:render-draw-colour-set! renderer (sdl2:make-colour 0 0 0 0))
|
|
;; Board
|
|
(for-each (lambda (field)
|
|
(render-field! renderer (cdr field) (caar field) (cdar field)))
|
|
orig-board)
|
|
;; Outline
|
|
;; Left border torso
|
|
(sdl2:render-fill-rect! renderer (sdl2:make-rect 495 400 10 (* 120 3)))
|
|
;; Top border torso
|
|
(sdl2:render-fill-rect! renderer (sdl2:make-rect 495 395 (+ 10 (* 120 4)) 10))
|
|
;; Bottom border torso
|
|
(sdl2:render-fill-rect! renderer (sdl2:make-rect 495 755 (+ 10 (* 120 4)) 10))
|
|
;; Right upper border torso
|
|
(sdl2:render-fill-rect! renderer (sdl2:make-rect 975 395 10 (+ 10 120)))
|
|
;; Right lower border torso
|
|
(sdl2:render-fill-rect! renderer (sdl2:make-rect 975 635 10 (+ 10 120)))
|
|
;; Top border neck
|
|
(sdl2:render-fill-rect! renderer (sdl2:make-rect 975 515 (+ 10 (* 120 2)) 10))
|
|
;; Bottom border neck
|
|
(sdl2:render-fill-rect! renderer (sdl2:make-rect 975 635 (+ 10 (* 120 2)) 10))
|
|
;; Left upper border head
|
|
(sdl2:render-fill-rect! renderer (sdl2:make-rect 1215 395 10 (+ 10 120)))
|
|
;; Left lower border head
|
|
(sdl2:render-fill-rect! renderer (sdl2:make-rect 1215 635 10 (+ 10 120)))
|
|
;; Top border head
|
|
(sdl2:render-fill-rect! renderer (sdl2:make-rect 1215 395 (+ 10 (* 120 2)) 10))
|
|
;; Bottom border head
|
|
(sdl2:render-fill-rect! renderer (sdl2:make-rect 1215 755 (+ 10 (* 120 2)) 10))
|
|
;; Right border head
|
|
(sdl2:render-fill-rect! renderer (sdl2:make-rect 1455 395 10 (+ 10 (* 120 3)))))
|
|
|
|
(define (draw-pieces! renderer)
|
|
(for-each (lambda (piece)
|
|
(sdl2:render-copy! renderer
|
|
(if (eq? 1 (alist-ref player: piece))
|
|
(if (eq? top: (alist-ref state: piece))
|
|
black-top black-bottom)
|
|
(if (eq? top: (alist-ref state: piece))
|
|
white-top white-bottom))
|
|
#f (alist-ref coords: piece)))
|
|
(alist-ref pieces: state)))
|
|
|
|
(define (draw-scene! renderer)
|
|
(sdl2:render-copy! renderer background)
|
|
(render-logo! renderer)
|
|
(draw-orig-board! renderer)
|
|
(draw-pieces! renderer)
|
|
(render-dice! renderer))
|
|
)
|