;; -*- 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))
  )