Pacman-Project/pacman-project/adt/level.rkt

#lang r7rs

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                Level ADT                                  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Contains all game logic: automatic Pac-Man movement, ghost AI, collision
;; detection, coin/key pickup, door opening, teleportation, pause, and time
;; management. Pac-Man moves automatically in its current direction. Arrow
;; keys queue a desired turn direction, which is applied at the next movement
;; tick if the path is clear. Ghost targeting follows the original Pac-Man
;; AI: Blinky chases directly, Pinky targets ahead, Inky uses vector
;; doubling from Blinky, Clyde is shy within 8 tiles. Contains NO graphics.

(define-library (pacman-project adt level)
  (import (scheme base)
          (pacman-project constants)
          (pacman-project adt position)
          (pacman-project adt maze)
          (pacman-project adt pacman)
          (pacman-project adt ghost)
          (pacman-project adt key)
          (pacman-project adt score)
          (pacman-project adt timer))
  (export make-level)

  (begin

    ;; make-level :: -> level
    ;; Creates a new level with all game objects including four ghosts.
    (define (make-level)
      (let ((maze (make-maze))
            (pacman (make-pacman 5 2))
            (key #f)
            (score (make-score))
            (timer (make-timer))
            (paused? #f)
            (game-over? #f)
            (queued-direction #f)
            (movement-timer 0)
            (on-coins-changed! (lambda () #f))
            (on-maze-changed! (lambda () #f))
            (on-ghosts-changed! (lambda () #f)))

        ;; Initialize key after maze is created.
        (set! key (make-key maze))

        ;;
        ;; Create four ghosts
        ;;

        (define blinky
          (make-ghost 'blinky
                      blinky-start-row blinky-start-col
                      blinky-scatter-row blinky-scatter-col
                      0))

        (define pinky
          (make-ghost 'pinky
                      pinky-start-row pinky-start-col
                      pinky-scatter-row pinky-scatter-col
                      pinky-exit-delay))

        (define inky
          (make-ghost 'inky
                      inky-start-row inky-start-col
                      inky-scatter-row inky-scatter-col
                      inky-exit-delay))

        (define clyde
          (make-ghost 'clyde
                      clyde-start-row clyde-start-col
                      clyde-scatter-row clyde-scatter-col
                      clyde-exit-delay))

        (define ghosts (list blinky pinky inky clyde))

        ;;
        ;; Ghost mode cycling
        ;;

        ;; Mode schedule: alternating scatter/chase durations.
        ;; After the last entry, ghosts stay in chase forever.
        (define mode-schedule
          (list (cons 'scatter scatter-duration-1)
                (cons 'chase chase-duration-1)
                (cons 'scatter scatter-duration-2)
                (cons 'chase chase-duration-2)
                (cons 'scatter scatter-duration-3)))

        (define current-schedule mode-schedule)
        (define mode-timer (if (null? mode-schedule) 0 (cdar mode-schedule)))
        (define global-mode 'scatter)

        ;;
        ;; Direction helpers
        ;;

        ;; direction->delta :: symbol -> (number . number)
        (define (direction->delta direction)
          (cond ((eq? direction 'right) (cons 0 1))
                ((eq? direction 'left) (cons 0 -1))
                ((eq? direction 'up) (cons -1 0))
                ((eq? direction 'down) (cons 1 0))
                (else (cons 0 0))))

        ;; reverse-direction :: symbol -> symbol
        (define (reverse-direction dir)
          (cond ((eq? dir 'right) 'left)
                ((eq? dir 'left) 'right)
                ((eq? dir 'up) 'down)
                ((eq? dir 'down) 'up)
                (else dir)))

        ;; can-move? :: symbol -> boolean
        ;; Checks if Pac-Man can move in the given direction.
        (define (can-move? direction)
          (let* ((delta (direction->delta direction))
                 (current-pos (pacman 'position))
                 (next-row (+ (current-pos 'row) (car delta)))
                 (next-col (+ (current-pos 'col) (cdr delta))))
            (cond
              ((or (< next-col 0) (>= next-col (maze 'cols))) #t)
              (((maze 'wall?) next-row next-col) #f)
              (((maze 'door?) next-row next-col) (key 'taken?))
              (else #t))))

        ;; ghost-can-move? :: ghost, symbol -> boolean
        ;; Checks if a ghost can move in the given direction.
        ;; Active ghosts cannot re-enter the ghost house.
        (define (ghost-can-move? ghost direction)
          (let* ((delta (direction->delta direction))
                 (pos (ghost 'position))
                 (next-row (+ (pos 'row) (car delta)))
                 (next-col (+ (pos 'col) (cdr delta))))
            (cond
              ;; Off-grid horizontally: tunnel
              ((or (< next-col 0) (>= next-col (maze 'cols))) #t)
              ;; Walls block
              (((maze 'wall?) next-row next-col) #f)
              ;; All doors block active ghosts (including ghost house door)
              (((maze 'door?) next-row next-col) #f)
              (else #t))))

        ;;
        ;; Distance calculation
        ;;

        ;; squared-distance :: number, number, number, number -> number
        (define (squared-distance r1 c1 r2 c2)
          (+ (* (- r1 r2) (- r1 r2))
             (* (- c1 c2) (- c1 c2))))

        ;;
        ;; Ghost targeting AI
        ;;

        ;; ghost-target :: ghost -> (number . number)
        ;; Returns the target tile (row . col) for the ghost based on its
        ;; current mode and type-specific AI.
        (define (ghost-target ghost)
          (let ((mode (ghost 'mode)))
            (cond
              ;; Scatter: head to assigned corner
              ((eq? mode 'scatter)
               (let ((st (ghost 'scatter-target)))
                 (cons (st 'row) (st 'col))))

              ;; Chase: type-specific targeting
              ((eq? mode 'chase)
               (let* ((pac-pos (pacman 'position))
                      (pac-row (pac-pos 'row))
                      (pac-col (pac-pos 'col))
                      (pac-dir (pacman 'direction))
                      (ghost-type (ghost 'type)))
                 (cond
                   ;; Blinky: target Pac-Man directly
                   ((eq? ghost-type 'blinky)
                    (cons pac-row pac-col))

                   ;; Pinky: target 2 tiles ahead of Pac-Man
                   ;; Original bug: when facing up, also offset 2 left
                   ((eq? ghost-type 'pinky)
                    (let ((ahead (direction->delta pac-dir)))
                      (if (eq? pac-dir 'up)
                          (cons (+ pac-row (* (car ahead) pinky-look-ahead))
                                (+ pac-col (* (cdr ahead) pinky-look-ahead) (- pinky-look-ahead)))
                          (cons (+ pac-row (* (car ahead) pinky-look-ahead))
                                (+ pac-col (* (cdr ahead) pinky-look-ahead))))))

                   ;; Inky: double the vector from Blinky to 2-ahead-of-Pac-Man
                   ((eq? ghost-type 'inky)
                    (let* ((ahead (direction->delta pac-dir))
                           (pivot-row (+ pac-row (* (car ahead) pinky-look-ahead)))
                           (pivot-col (+ pac-col (* (cdr ahead) pinky-look-ahead)))
                           (blinky-pos (blinky 'position)))
                      (cons (+ pivot-row (- pivot-row (blinky-pos 'row)))
                            (+ pivot-col (- pivot-col (blinky-pos 'col))))))

                   ;; Clyde: chase Pac-Man, but scatter when within 8 tiles
                   ((eq? ghost-type 'clyde)
                    (let* ((ghost-pos (ghost 'position))
                           (dist-sq (squared-distance
                                     (ghost-pos 'row) (ghost-pos 'col)
                                     pac-row pac-col)))
                      (if (< dist-sq (* clyde-shy-distance clyde-shy-distance))
                          (let ((st (ghost 'scatter-target)))
                            (cons (st 'row) (st 'col)))
                          (cons pac-row pac-col))))

                   ;; Fallback
                   (else (cons pac-row pac-col)))))

              ;; Default (in-house etc): stay put
              (else
               (let ((pos (ghost 'position)))
                 (cons (pos 'row) (pos 'col)))))))

        ;; choose-ghost-direction :: ghost -> symbol
        ;; Picks the best direction for the ghost at its current tile.
        ;; Cannot reverse; chooses direction minimizing distance to target.
        ;; Tie-break order: up, left, down, right.
        (define (choose-ghost-direction ghost)
          (let* ((target (ghost-target ghost))
                 (target-row (car target))
                 (target-col (cdr target))
                 (current-dir (ghost 'direction))
                 (reverse-dir (reverse-direction current-dir))
                 (pos (ghost 'position))
                 (row (pos 'row))
                 (col (pos 'col))
                 (candidates '(up left down right)))
            (let loop ((dirs candidates)
                       (best-dir current-dir)
                       (best-dist 999999999))
              (if (null? dirs)
                  ;; If no valid direction found, reverse as last resort
                  (if (= best-dist 999999999) reverse-dir best-dir)
                  (let* ((dir (car dirs))
                         (delta (direction->delta dir))
                         (nr (+ row (car delta)))
                         (nc (+ col (cdr delta))))
                    (if (and (not (eq? dir reverse-dir))
                             (ghost-can-move? ghost dir))
                        (let ((dist (squared-distance nr nc target-row target-col)))
                          (if (< dist best-dist)
                              (loop (cdr dirs) dir dist)
                              (loop (cdr dirs) best-dir best-dist)))
                        (loop (cdr dirs) best-dir best-dist)))))))

        ;;
        ;; Ghost movement
        ;;

        ;; move-ghost! :: ghost -> /
        ;; Moves a ghost one tile in its chosen direction.
        (define (move-ghost! ghost)
          (let* ((dir (ghost 'direction))
                 (delta (direction->delta dir))
                 (pos (ghost 'position))
                 (next-row (+ (pos 'row) (car delta)))
                 (next-col (+ (pos 'col) (cdr delta))))
            ;; Handle tunnel teleportation
            (cond
              ((< next-col 0)
               ((pos 'col!) (- (maze 'cols) 1)))
              ((>= next-col (maze 'cols))
               ((pos 'col!) 0))
              (else
               ((ghost 'move!) (car delta) (cdr delta))))))

        ;; advance-ghost! :: ghost -> /
        ;; Chooses direction and moves one ghost.
        (define (advance-ghost! ghost)
          (when (not (ghost 'in-house?))
            ;; Handle queued reverse from mode change
            (when ((ghost 'consume-reverse!))
              ((ghost 'direction!) (reverse-direction (ghost 'direction))))
            ;; Choose best direction at current tile
            (let ((new-dir (choose-ghost-direction ghost)))
              ((ghost 'direction!) new-dir)
              (move-ghost! ghost))
            (on-ghosts-changed!)))

        ;; exit-ghost-house! :: ghost -> /
        ;; Moves a ghost from inside the house to the exit position.
        (define (exit-ghost-house! ghost)
          (let ((pos (ghost 'position)))
            ((pos 'row!) ghost-house-exit-row)
            ((pos 'col!) ghost-house-exit-col)
            ((ghost 'direction!) 'left)
            (on-ghosts-changed!)))

        ;;
        ;; Ghost-Pacman collision
        ;;

        ;; check-ghost-collision! :: -> /
        ;; Checks if any ghost occupies the same tile as Pac-Man.
        (define (check-ghost-collision!)
          (let ((pac-pos (pacman 'position)))
            (for-each
             (lambda (ghost)
               (when (and (not (ghost 'in-house?))
                          (= ((ghost 'position) 'row) (pac-pos 'row))
                          (= ((ghost 'position) 'col) (pac-pos 'col)))
                 (set! game-over? #t)))
             ghosts)))

        ;;
        ;; Mode cycling
        ;;

        ;; update-ghost-mode! :: number -> /
        ;; Advances the global mode timer and switches scatter/chase.
        (define (update-ghost-mode! delta-time)
          (when (not (null? current-schedule))
            (set! mode-timer (- mode-timer delta-time))
            (when (<= mode-timer 0)
              (set! current-schedule (cdr current-schedule))
              (if (null? current-schedule)
                  ;; Permanent chase after schedule ends
                  (begin
                    (set! global-mode 'chase)
                    (for-each (lambda (g) ((g 'mode!) 'chase)) ghosts))
                  (let ((next-mode (caar current-schedule))
                        (next-duration (cdar current-schedule)))
                    (set! global-mode next-mode)
                    (set! mode-timer next-duration)
                    (for-each (lambda (g)
                                (when (not (g 'in-house?))
                                  ((g 'mode!) next-mode)))
                              ghosts))))))

        ;;
        ;; Update ghosts
        ;;

        ;; update-ghosts! :: number -> /
        ;; Updates all ghost timers, house exits, and movement.
        (define (update-ghosts! delta-time)
          (for-each
           (lambda (ghost)
             ;; Update house timer for ghosts still inside
             (let ((was-in-house? (ghost 'in-house?)))
               ((ghost 'update-house-timer!) delta-time)
               ;; Ghost just exited house
               (when (and was-in-house? (not (ghost 'in-house?)))
                 (exit-ghost-house! ghost)
                 ((ghost 'mode!) global-mode)))
             ;; Movement tick for active ghosts
             (when (not (ghost 'in-house?))
               (let ((mt ((ghost 'advance-movement-timer!) delta-time)))
                 (when (>= mt ghost-speed-ms)
                   (advance-ghost! ghost)
                   ((ghost 'reset-movement-timer!))))))
           ghosts))

        ;;
        ;; Coin logic
        ;;

        ;; eat-coin! :: number, number -> /
        (define (eat-coin! row col)
          ((maze 'cell-set!) row col cell-type-empty)
          ((score 'increase!))
          ((timer 'increase!))
          (on-coins-changed!))

        ;;
        ;; Key logic
        ;;

        ;; pick-up-key! :: number, number -> /
        (define (pick-up-key! row col)
          ((maze 'cell-set!) row col cell-type-empty)
          ((key 'take!))
          (on-coins-changed!))

        ;;
        ;; Teleportation logic
        ;;

        ;; teleport-horizontal! :: number, number -> /
        (define (teleport-horizontal! row col)
          (let ((pac-pos (pacman 'position)))
            (cond ((< col 0)
                   ((pac-pos 'col!) (- (maze 'cols) 1))
                   ((pac-pos 'row!) row))
                  ((>= col (maze 'cols))
                   ((pac-pos 'col!) 0)
                   ((pac-pos 'row!) row)))))

        ;;
        ;; Movement logic
        ;;

        ;; move-pacman! :: symbol -> /
        (define (move-pacman! direction)
          (let* ((delta (direction->delta direction))
                 (delta-row (car delta))
                 (delta-col (cdr delta))
                 (current-pos (pacman 'position))
                 (next-row (+ (current-pos 'row) delta-row))
                 (next-col (+ (current-pos 'col) delta-col)))

            ((pacman 'direction!) direction)

            (cond
              ((or (< next-col 0) (>= next-col (maze 'cols)))
               (teleport-horizontal! next-row next-col))

              (((maze 'door?) next-row next-col)
               (when (key 'taken?)
                 ((maze 'remove-door!) next-row next-col)
                 (on-maze-changed!)))

              (else
               (when (not ((maze 'wall?) next-row next-col))
                 ((pacman 'move!) delta-row delta-col)
                 (cond
                   (((maze 'key?) next-row next-col)
                    (pick-up-key! next-row next-col))
                   (((maze 'coin?) next-row next-col)
                    (eat-coin! next-row next-col))))))))

        ;; advance-pacman! :: -> /
        (define (advance-pacman!)
          (when (not (or ((timer 'time-up?)) game-over?))
            (let ((current-dir (pacman 'direction)))
              (cond
                ((and queued-direction (can-move? queued-direction))
                 (move-pacman! queued-direction)
                 (set! queued-direction #f))
                ((can-move? current-dir)
                 (move-pacman! current-dir))))))

        ;;
        ;; Pause logic
        ;;

        (define (toggle-pause!)
          (set! paused? (not paused?)))

        ;;
        ;; Key handling
        ;;

        ;; key-press! :: symbol -> /
        (define (key-press! pressed-key)
          (cond
            ((eq? pressed-key 'escape) (toggle-pause!))
            ((not paused?)
             (cond
               ((eq? pressed-key 'right) (set! queued-direction 'right))
               ((eq? pressed-key 'left) (set! queued-direction 'left))
               ((eq? pressed-key 'up) (set! queued-direction 'up))
               ((eq? pressed-key 'down) (set! queued-direction 'down))))))

        ;;
        ;; Update (game loop)
        ;;

        ;; update! :: number -> /
        (define (update! delta-time)
          (when (not (or paused? game-over?))
            ((timer 'decrease!) delta-time)
            ;; Pac-Man movement
            (set! movement-timer (+ movement-timer delta-time))
            (when (>= movement-timer pacman-speed-ms)
              (advance-pacman!)
              (set! movement-timer 0)
              (check-ghost-collision!))
            ;; Ghost mode cycling and movement
            (update-ghost-mode! delta-time)
            (update-ghosts! delta-time)
            (check-ghost-collision!)))

        ;;
        ;; Callbacks
        ;;

        (define (set-on-coins-changed! callback)
          (set! on-coins-changed! callback))

        (define (set-on-maze-changed! callback)
          (set! on-maze-changed! callback))

        (define (set-on-ghosts-changed! callback)
          (set! on-ghosts-changed! callback))

        ;;
        ;; Dispatch
        ;;

        (define (dispatch-level msg)
          (cond ((eq? msg 'maze) maze)
                ((eq? msg 'pacman) pacman)
                ((eq? msg 'ghosts) ghosts)
                ((eq? msg 'key) key)
                ((eq? msg 'score) score)
                ((eq? msg 'timer) timer)
                ((eq? msg 'paused?) paused?)
                ((eq? msg 'game-over?) game-over?)
                ((eq? msg 'key-press!) key-press!)
                ((eq? msg 'update!) update!)
                ((eq? msg 'set-on-coins-changed!) set-on-coins-changed!)
                ((eq? msg 'set-on-maze-changed!) set-on-maze-changed!)
                ((eq? msg 'set-on-ghosts-changed!) set-on-ghosts-changed!)
                (else (error "Level ADT -- Unknown message:" msg))))

        dispatch-level))))