pacman, ncurses, lisp

pacman.lisp

(defpackage :pacman
  (:use :cl))

(in-package :pacman)

;;; The charms/ll library contains all of the FFI bindings to Ncurses.
(ql:quickload :cl-charms)

;;; Here are all of the functions I'll be using from Ncurses.
(import '(
	  ;; Constants/Variables
	  charms/ll:false
	  charms/ll:true
	  charms/ll:err
	  charms/ll:*stdscr*

	  ;; Start/End NCurses
	  charms/ll:initscr
	  charms/ll:endwin

	  ;; Force Output/Clear screen.
	  charms/ll:refresh
	  charms/ll:erase

	  ;; Cursor
	  charms/ll:curs-set

	  ;; Keyboard Input
	  charms/ll:noecho
	  charms/ll:nodelay
	  charms/ll:cbreak
	  charms/ll:keypad

	  charms/ll:getch

	  ;; Output
	  charms/ll:mvaddch
	  charms/ll:mvaddstr

	  ;; Colors
	  charms/ll:attron
	  charms/ll:start-color
	  charms/ll:init-pair
	  charms/ll:init-color
	  charms/ll:has-colors
	  charms/ll:color-pair

	  ;; Function keys
	  charms/ll:key_left
	  charms/ll:key_right
	  charms/ll:key_up
	  charms/ll:key_down))

;;; Documentation strings mostly copied from the Ncurses man pages.
(setf (documentation 'false 'variable)
      "Defined to be 0"
      (documentation 'true 'variable)
      "Defined to be 1"
      (documentation 'err 'variable)
      "Defined to be -1"
      (documentation '*stdscr* 'variable)
      "Upon  initializing  curses,  a default window called stdscr, which is the
size of the terminal screen, is created.  Many curses functions use  this
window."
      (documentation 'cbreak 'function)
      "The cbreak routine disables  line  buffering  and erase/kill
character-processing  (interrupt  and flow control characters
are unaffected), making characters typed by the user  immediately  available
to the program."
      (documentation 'initscr 'function)
      "The  initscr code determines the terminal type and initializes all curses
data structures.  initscr also causes the first call to refresh to  clear
the screen.  If errors occur, initscr writes an appropriate error message
to standard error and exits; otherwise, a pointer is returned to stdscr."
      (documentation 'endwin 'function)
      "A program should always call endwin before exiting or escaping from curses
mode  temporarily.  This routine restores tty modes, moves the cursor
to the lower left-hand corner of the screen and resets the terminal  into
the  proper  non-visual mode."
      (documentation 'curs-set 'function)
      "sets the cursor state to invisible, normal, or  very
visible for visibility equal to 0, 1, or 2 respectively.  If the terminal
supports the visibility requested, the previous cursor state is returned;
otherwise, ERR is returned."
      (documentation 'noecho 'function)
      "The echo and noecho routines control whether characters typed by the user
are  echoed by getch as they are typed."
      (documentation 'nodelay 'function)
      "The nodelay option causes getch to be a non-blocking call.  If  no  input
is  ready, getch returns ERR.  If disabled (bf is FALSE), getch waits un‐
til a key is pressed."
      (documentation 'mvaddch 'function)
      "The addch, waddch, mvaddch and mvwaddch routines  put  the  character  ch
into  the  given  window  at  its  current window position, which is then
advanced"
      (documentation 'mvaddstr 'function)
      "Write the (null-terminated) character string str on the stdscr."
      (documentation 'keypad 'function)
      "The  keypad option enables the keypad of the user's terminal.  If enabled
i.e. (bf is TRUE), the user can press a function key (such as  an  arrow  key)
and  wgetch  returns  a single value representing the function key, as in
KEY_LEFT.  If disabled (bf is FALSE), curses does not treat function keys
specially  and  the program has to interpret the escape sequences itself."
      (documentation 'getch 'function)
      "The getch, wgetch, mvgetch and mvwgetch, routines read a  character  from
the  window.   In no-delay mode, if no input is waiting, the value ERR is
returned.  In delay mode, the program waits until the system passes  text
through  to the program.  Depending on the setting of cbreak, this is af‐
ter one character (cbreak mode), or after  the  first  newline  (nocbreak
mode).   In half-delay mode, the program waits until a character is typed
or the specified timeout has been reached."
      (documentation 'refresh 'function)
      "The refresh and wrefresh routines (or wnoutrefresh and doupdate) must  be
called to get actual output to the terminal, as other routines merely ma‐
nipulate data structures.  The routine wrefresh copies the  named  window
to  the  physical  terminal  screen,  taking into account what is already
there to do optimizations.  The refresh routine is the same, using stdscr
as  the  default  window."
      (documentation 'erase 'function)
      "The erase and werase routines copy blanks to every position in  the
window, clearing the screen."
      (documentation 'attron 'function)
      "The routine attron turns on the named attributes without
affecting any others."
      (documentation 'start-color 'function)
      "curses  support  color  attributes on terminals with that capability.  To
use these routines  start_color  must  be  called,  usually  right  after
initscr"
      (documentation 'init-pair 'function)
      "A programmer initializes a color-pair with the routine init_pair."
      (documentation 'has-colors 'function)
      "The routine has_colors returns  TRUE  or  FALSE,  depending  on
whether  the  terminal  has color capabilities"
      (documentation 'color-pair 'function)
      "After a pair has  been  initialized, (COLOR-PAIR n),
can be used as a new video attribute.")

;;; time-loop

;;; The base unit game time will be frames (think frames per second)
;;; to keep time units discrete and make runs of the game repeatable.
;;; A frame is the unit of time from one rendering of the screen to the next.

;;; The update function will have no notion of time, and will always only update
;;; one frame.

(defun time-loop (fn &key (fps 60) (quit-val :quit))
  "Calls FN FPS times per second. Quits if FN returns QUIT-VAL."
  (let ((ms-per-frame (fps->ms-per-frame fps))
	(last-update-time (get-internal-real-time))
	(dt-ms))
    (loop
       do
	 (setq dt-ms (time-delta-ms last-update-time (get-internal-real-time)))
	 (cond
	   ((>= dt-ms ms-per-frame)
	    ;; Call FN and see if we should quit.
	    (when (eq quit-val (funcall fn))
	      (return-from time-loop))
	    (setq last-update-time (get-internal-real-time)))
	   (t
	    ;; Sleep off the difference.
	    (sleep (/ (- ms-per-frame dt-ms) ms/s)))))))

(defconstant ms/s 1000 "Milliseconds per second.")
(defun fps->ms-per-frame (fps)
  "Converts frames per second to milliseconds per frame."
  (/ ms/s fps))

#+example
(fps->ms-per-frame 60)
;; => 50/3

(defun time-delta-ms (t1 t2)
  "Returns ms elapsed at t2 since t1. t1 and t2 are expected to be in
internal time units."
  (* (/ internal-time-units-per-second ms/s) (- t2 t1)))

#+example
(time-delta-ms 16 987)
;; => 971

#+example
(time-loop (let ((count 0))
	     #'(lambda ()
		 (prin1 (incf count))
		 (when (= count 15)
		   :quit)))
	   :fps 5)
;; Counts to 15 at 5 FPS.

;;; Ncurses will buffer input when in nodelay mode.
(defun get-inputs ()
  "Gathers all buffered input into a list."
  (loop
     for char = (getch)
     while (/= char err)
     collect char))

(defun with-curses (fn)
  "Sets up and tears down Ncurses around a call to FN."
  ;; Unwind-Protect makes sure (endwin) is called even if an
  ;; exception is thrown or a condition is signaled.
  (unwind-protect
       (progn
	 (initscr)
	 (funcall fn))
    (endwin)))

(defvar *game* nil
  "The current state of the game.")

(defun pacman-frame ()
  "Gathers all inputs, advances *game* by one frame, and renders."
  (let ((inputs (get-inputs)))
    (setf *game* (pacman-update inputs))
    (render)))

;;; pacman-update takes an input so we can supply our own input
;;; not gathered from keypresses for debugging.

(defun pacman-update (input &optional (game *game*))
  "Given input, a list of key-presses, returns game updated by one frame."

  ;; Generally, the game update skeleton is 4 sequential steps:
  ;; 1. Handle Input
  ;;     update the game to reflect interpreted input.
  ;;     e.g.: Player presses down, then Pac-Man tries to go down.

  ;; 2. Artificial Intelligence
  ;;     make any new decisions that need to be made
  ;;     update timers
  ;;     e.g.: If a ghost is at a junction, decide which way to go next.
  ;;     If the power-up timer has expired, return to normal mode.

  ;; 3. Physics/Mark Collisions
  ;;     Move everyone to their new positions.
  ;;     e.g.: Ghosts move and pacman move.
  ;;     Mark any collisons.
  ;;     e.g.: is Pac-Man colliding with a fruit?
  ;;     Is Pac-Man colliding with a ghost?

  ;; 4. Resolve Collisions
  ;;     Go through the marked collisions and resolve them.
  ;;     e.g.: if Pac-Man ate a powerup, make sure to go into the powerup state.
  ;;     if Pac-Man collides with a ghost, determine if we should:
  ;;       eat it if we are powered up, lose a life if we have extras,
  ;;       or game over.

  (resolve-collisions
   (physics
    (ai
     (handle-input input game)))))

;;; Above is the high level specification. I need to figure out a way to write
;;; render, resolve-collisions, physics, ai, and handle-input.
;;; This implies a lot of problems I need to solve:
;;;   What is the game data structure?
;;;   How will I "mark" collisions? Will it be part of the game structure?
;;;   How can I keep these high-level functions extensible? I'd like to be able
;;;     to add new game rules one at a time, without constantly redefining
;;;     functions.
;;;   How can I render debug drawings to a non-ncurses window?
;;;
;;; All of these questions are really high level, and I don't have any answers to
;;; them. I usually start with rendering because I can *see* the answer
;;; to those kinds of questions.

;;;; Rendering.

;;; I'll need a 2d point structure, for specifying positions.

(defstruct (pos (:constructor)
		(:constructor pos (&optional x y))
		(:conc-name p))
  "A 2D point. Accessors are PX and PY."
  (x 0) (y 0))

#+example
(pos 3 4)
;; => #S(POS :X 3 :Y 4)

(defun +pos (&rest ps)
  "Add ps together. Return (pos) if no ps provided,
return the first if only one p is provided."
  (reduce #'(lambda (p1 p2)
	      (pos (+ (px p1) (px p2))
		   (+ (py p1) (py p2))))
	  ps
	  :initial-value (pos)))

#+example
(+pos)
;; => #S(POS :X 0 :Y 0)
#+example
(+pos (pos 1 2))
;; => #S(POS :X 1 :Y 2)
#+example
(+pos (pos 1 1) (pos 2 2) (pos 3 3))
;; => #S(POS :X 6 :Y 6)

;;; It'd be great to be able to see a printout of a drawing
;;; so that I don't have to run everything in the terminal,
;;; just to test something.

;;; One way I can think of to do this is to create an intermediate
;;; representation of the terminal output: a draw buffer.
;;; I'll do all "rendering" to the draw-buffer, and then update
;;; the Ncurses window from there.

;;; The other way I thought of, which I will do, is to keep the draw
;;; buffer in sync with the Ncurses window, by providing an interface
;;; that modifies both simultaneously.

;;; An intermediate representation would be a good idea if renders were
;;; expensive. Then we could keep track of deltas, and only render parts
;;; that had changed.
;;; The buffer can be modified destructively, since renders are
;;; relatively cheap, and we can hang onto the game state instead.

;;; The draw buffer will conceptually be two 2d grids. One will have
;;; chars and the other will have color pair indices.

(defparameter *buffer-width* 80 "The width of the *draw-buffer*")
(defparameter *buffer-height* 40 "The height of the *draw-buffer*")

(defstruct draw-buffer
  "A 2D grid data-type for representing a buffer that is drawn to."
  (width *buffer-width*)
  (height *buffer-height*)
  (chars nil)
  (color-pairs nil))

(defun create-empty-draw-buffer (&key (width *buffer-width*) (height *buffer-height*))
  "Create a draw buffer filled with empty space."
  (let ((length (* width height)))
    (make-draw-buffer
     :width width
     :height height
     :chars (make-array length :initial-element #\Space)
     :color-pairs (make-array length :initial-element 0))))

#+example
(create-empty-draw-buffer :width 3 :height 3)
#||
=>
#S(DRAW-BUFFER
:WIDTH 3
:HEIGHT 3
:CHARS #(#\  #\  #\  #\  #\  #\  #\  #\  #\ )
:COLOR-PAIRS #(0 0 0 0 0 0 0 0 0))

||#

(defvar *draw-buffer* (create-empty-draw-buffer)
  "All drawings are buffered in *draw-buffer* before being rendered.")

(defun update-draw-buffer! (pos char color-pair draw-buffer)
  "Destructively updates draw-buffer with char and color pair index at pos."
  (let ((idx (pos->draw-buffer-idx pos draw-buffer)))
    (setf (svref (draw-buffer-chars draw-buffer) idx) char)
    (setf (svref (draw-buffer-color-pairs draw-buffer) idx) color-pair))
  draw-buffer)

#+example
(update-draw-buffer! (pos 1 2) #\a 2
		     (create-empty-draw-buffer :width 3 :height 3))
#||
=>
#S(DRAW-BUFFER
:WIDTH 3
:HEIGHT 3
:CHARS #(#\  #\  #\  #\  #\  #\  #\  #\a #\ )
:COLOR-PAIRS #(0 0 0 0 0 0 0 2 0))

||#

(defun draw-buffer-put-str! (pos str color-pair draw-buffer)
  "Destructively updates draw-buffer with a new string at pos."
  (loop
     for char across str
     for i from 0
     ;; Just cut-off at the end of a the buffer.
     until (= (+ (px pos) i) (draw-buffer-width draw-buffer))
     do
       (update-draw-buffer! (+pos pos (pos i 0)) char color-pair draw-buffer))
  draw-buffer)

#+example
(draw-buffer-put-str! (pos 2 1) "Hi!" 2 (create-empty-draw-buffer :width 10 :height 3))
#||
=>
#S(DRAW-BUFFER
:WIDTH 10
:HEIGHT 3
:CHARS #(#\  #\  #\  #\  #\  #\  #\  #\  #\  #\  #\  #\  #\H #\i #\! #\  #\
#\  #\  #\  #\  #\  #\  #\  #\  #\  #\  #\  #\  #\ )
:COLOR-PAIRS #(0 0 0 0 0 0 0 0 0 0 0 0 2 2 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))

||#

(defun pos->draw-buffer-idx (pos draw-buffer)
  "Converts a position to an index into the draw buffer."
  (+ (px pos) (* (py pos) (draw-buffer-width draw-buffer))))

#+example
(pos->draw-buffer-idx (pos 3 1))
;; => 83

(defun erase-draw-buffer ()
  "Replaces *draw-buffer* with an empty draw-buffer."
  (setf *draw-buffer* (create-empty-draw-buffer)))

;;; I'll provide a common interface to Ncurses AND our draw buffer.

(defun putchar (char pos cp)
  "Puts a character to the draw-buffer/Ncurses window given
the start position and color-pair."
  (setq pos (floor2 pos))
  (unless (or (minusp (px pos))
	      (minusp (py pos)))
    (set-color-pair cp)
    (mvaddch (py pos) (px pos) (char-code char))
    (update-draw-buffer! pos char cp *draw-buffer*)))

(defun floor2 (pos &optional (divisor 1))
  "Floors a position."
  (pos (floor (px pos) divisor)
       (floor (py pos) divisor)))

(defun putstr (str pos cp)
  "Puts a string to the draw-buffer/Ncurses window given
the start position and color-pair."
  (set-color-pair cp)
  (mvaddstr (py pos) (px pos) str)
  (draw-buffer-put-str! pos str cp *draw-buffer*))

(defun clearscr ()
  "Clears the draw-buffer/Ncurses window."
  (erase)
  (erase-draw-buffer))

;;; Ncurses colors come in color pairs indexed by positive integers.
;;; They are set in a "palette" style, using attron to set the current color pair.

(defun set-color-pair (cp)
  "Turns on the attribute associated with the given color pair index."
  ;; Color-pair creates an attribute given an index,
  ;; and attron turns the attribute on.
  (attron (color-pair cp)))

;;; Finally I'll print the chars of the draw buffer to the screen.
(defun print-draw-buffer (&optional (draw-buffer *draw-buffer*))
  "Prints a draw-buffer to the screen without color."
  (fresh-line)
  (loop
     for x from 0
     for char across (draw-buffer-chars draw-buffer)
     when (= x (draw-buffer-width draw-buffer)) do
       (terpri)
       (setf x 0)
     do (princ char)))

#+example
(print-draw-buffer
 (draw-buffer-put-str!
  (pos) "Go!" 1
  (draw-buffer-put-str!
   (pos 0 2) "Hi!" 2
   (create-empty-draw-buffer :width 3 :height 3))))
#||
Output:
Go!
   
Hi!
||#
;; => NIL

;;; Since I'm not working in a terminal, I define a function to open and run
;;; an expression in the terminal, for convenience.

(defun run-in-terminal (sexp)
  "Uses UIOP's run-program to open a new terminal and lisp instance, and
run sexp inside of it. Loads the pacman.lisp and runs sexp inside of :pacman
package."
  (uiop:run-program (run-in-terminal-str sexp))
  (values))

(defun run-in-terminal-str (sexp)
  "Creats a shell string to load the pacman.lisp and run SEXP in
package :pacman."
  (let* ((lisp-str (format nil "sbcl --load ~~/Projects/lisp/pacman/pacman.lisp ~
 --eval '(in-package :pacman)' --eval '~S'" sexp))
	 (term-str (format nil "urxvt -e ~A" lisp-str)))
    (remove #\newline term-str)))

#+example
(run-in-terminal-str '(try-draw-string))
;; => "urxvt -e sbcl --load ~/Projects/lisp/pacman/pacman.lisp --eval '(in-package :pacman)' --eval '(TRY-DRAW-STRING)'"

(defun try-draw-string ()
  (with-curses
      #'(lambda ()
	  (start-color)
	  (init-pair 1 charms/ll:color_blue charms/ll:color_red)
	  (putstr "Hello, world!" (pos 3 2) 1)
	  (refresh)
	  (wait-for-keypress))))

(defun wait-for-keypress ()
  "Instructs Ncurses to wait for a key to be pressed before continuing."
  (nodelay *stdscr* false)
  (getch)
  (nodelay *stdscr* true))

#+example
(run-in-terminal '(try-draw-string))
;; Great! Hello, World! in barely legible blue text on red background.

;;; Since the arena doesn't ever change I'll start with drawing it.

;;; +        = Corner
;;; |        = Vertical wall
;;; - (dash) = Horizontal wall

;;; .        = Dots
;;; @        = Power Pellet

;;; _ (underscore) = Doorway

(defparameter *arena*
  (vector "+------------++------------+"
	  "|............||............|"
	  "|.+--+.+---+.||.+---+.+--+.|"
	  "|@|  |.|   |.||.|   |.|  |@|"
	  "|.+--+.+---+.++.+---+.+--+.|"
	  "|..........................|"
	  "|.+--+.++.+------+.++.+--+.|"
	  "|.+--+.||.+--++--+.||.+--+.|"
	  "|......||....||....||......|"
	  "+----+.|+--+ || +--+|.+----+"
	  "     |.|+--+ ++ +--+|.|     "
	  "     |.||          ||.|     "
	  "     |.|| +--__--+ ||.|     "
	  "-----+.++ |      | ++.+-----"
	  "      .   |      |   .      "
	  "-----+.++ |      | ++.+-----"
	  "     |.|| +------+ ||.|     "
	  "     |.||          ||.|     "
	  "     |.|| +------+ ||.|     "
	  "+----+.++ +--++--+ ++.+----+"
	  "|............||............|"
	  "|.+--+.+---+.||.+---+.+--+.|"
	  "|.+-+|.+---+.++.+---+.|+-+.|"
	  "|@..||.......  .......||..@|"
	  "+-+.||.++.+------+.++.||.+-+"
	  "+-+.++.||.+--++--+.||.++.+-+"
	  "|......||....||....||......|"
	  "|.+----++--+.||.+--++----+.|"
	  "|.+--------+.++.+--------+.|"
	  "|..........................|"
	  "+--------------------------+")
  "The arena is stored as a vector of strings.")

;;; I chose to record blocked off areas as x, because they are
;;; rendered with a different background. The powerups and pellets
;;; are dynamic (they can be eaten) so even though I put them in *arena*
;;; I won't consider them part of the arena.

(defparameter *arena-chars* '(#\+ #\- #\| #\_))

(defun arena-char-type (arena-char)
  "Look up the arena type associated with the arena-char."
  (ecase arena-char
    ;; Mechanically, corners are identical to walls. They are also the same color.
    ((#\+ #\- #\|) :wall)
    (#\_ :door)))

#+example
(arena-char-type #\-)
;; => :WALL

;;; Since colors are not constant, I'll pass an association list in as a
;;; parameter to draw-arena.

#+example
(loop for str across *arena* do
     (princ #\")
     (loop for char across str do
	  (princ char))
     (princ #\")
     (terpri))

(defun draw-arena (&optional (arena-cps '((:wall . 0) (:door . 0))))
  "Draws the arena with the given arena-cps alist.
arena-cps is an association from an arena-type
to a color-pair index."
  (loop
     for row from 0
     for str across *arena* do
       (loop
	  for col from 0
	  for char across str
	  when (member char *arena-chars*) do
	    (putchar char
		     (pos col row)
		     (cdr (assoc (arena-char-type char) arena-cps))))))

#+example
(progn
  (clearscr)
  (draw-arena)
  (print-draw-buffer))

(defun try-draw-arena ()
  (with-curses
      #'(lambda ()
	  (clearscr)
	  (start-color)
	  (init-pair 1 charms/ll:color_blue charms/ll:color_black)
	  (init-pair 2 charms/ll:color_red charms/ll:color_black)
	  (draw-arena '((:wall . 1) (:door . 2)))
	  (wait-for-keypress))))

#+example
(run-in-terminal '(try-draw-arena))
;;; Seems fine to me!

;;; Next I'll deal with drawing Pac-Man onto the screen.
;;; I still don't know how everything is going to be stored in the game
;;; structure, but I can still build a low-level function that I won't
;;; need to change.

(defparameter *directions* '(:left :right :up :down))

(defun draw-pacman-char (&key cp pos dir mouth-open?)
  "Given a color pair, an absolute position, and the direction
that Mr. Pac-Man is facing, and whether his mouth is open, draw him."
  (let ((char (pacman-char dir mouth-open?)))
    (putchar char pos cp)))

(defun pacman-char (dir mouth-open?)
  "Return the mouth char for pacman given direction."
  (if mouth-open?
      (ecase dir
	(:left #\>)
	(:right #\<)
	(:up #\V)
	(:down #\^))
      #\O))

#+example
(let ((*draw-buffer* (create-empty-draw-buffer)))
  (draw-arena '((:wall . 1) (:door . 2)))
  (draw-pacman-char :cp 3 :pos (pos 1 3) :dir :up :mouth-open? t)
  (draw-pacman-char :cp 3 :pos (pos 1 2) :dir :up :mouth-open? nil)
  (draw-pacman-char :cp 3 :pos (pos 2 1) :dir :right :mouth-open? t)
  (print-draw-buffer))

;;;; Moving Pac-Man

;;; Ok now I'm going to work on getting pacman to move around the screen
;;; I'm not going to worry about collisions, just yet.

;;; I need to think about fast he'll move. Remember time units are in "frames".
;;; Right now our arena is a giant 2d grid of characters, but moving 1 character
;;; (henceforth tile) per frame is too fast. We'll move at sub-tile/frame speeds.

;;; According to the Pac-Man Dossier collision checks use pixels, and there are 8
;;; pixels per tile.
;;; To make it easier, I'll choose a multiple of 8, 256, for an even finer
;;; sub-pixel/frame granularity.

;;; So to recap, there are three units of measure: tile (or character), pixel, and sub-pixel.
;;; We'll use sub-pixel measurements to store position and speeds.
(defparameter *pixels/tile* 8 "The number of pixels in a tile.")

(defparameter *sub-pixels/pixel* 256
  "The number of sub-pixels in a pixel.
Sub-pixels are the canonical unit of in-game position.")

(defparameter *frames/second* 60 "Number of frames per second used for Pac-Man.")

(defun make-speed (tiles/second)
  "Converts a speed in tiles/second to a speed into canonical sub-pixels/frame."
  (round (/ (* *pixels/tile* *sub-pixels/pixel* tiles/second)
	    *frames/second*)))

;;; All speeds are in sub-pixels/frame, but we'll define speeds in
;;; relation to seconds, and convert to frames, in case we change our FPS.

;;; I have no idea how fast pacman is. I'm guessing about 1 1/2 tiles per second.
(defparameter *pacman-speed* (make-speed 3/2) "Pac-Man's speed.")

;;; I'll start by storing pacman as an association list.
(defvar *pacman* nil "The current state of pacman, stored as an alist.")

;;; Positions are stored in sub-pixels, relative to the top-left corner of the arena.
(defun tile-pos (pos)
  "Convert a tile-pos to a sub-pixel pos."
  (*pos pos *pixels/tile* *sub-pixels/pixel*))

(defun *pos (pos &rest nums)
  "Scale pos by the result of multiplying nums.
If no nums are provided, then returns pos."
  (let ((factor (apply #'* nums)))
    (pos (* factor (px pos))
	 (* factor (py pos)))))


(setq *pacman* (pairlis '(:pos
			  :dir)
			(list (tile-pos (pos 1 1))
			      :right)))
;; => ((:DIR . :RIGHT) (:POS . #S(POS :X 2048 :Y 2048)))

(defun move-pacman (pacman)
  "Move pacman in the direction he is facing by his speed for one frame."
  (let ((pos (get-binding-val :pos pacman))
	(dir (get-binding-val :dir pacman)))
    (update-alist '(:pos) (list (move-pos pos dir *pacman-speed*)) pacman)))

(defun move-pos (pos dir speed)
  "Updates position given the direction and speed for one frame of time."
  (ecase dir
    (:up (+pos pos (pos 0 (- speed))))
    (:down (+pos pos (pos 0 speed)))
    (:left (+pos pos (pos (- speed) 0)))
    (:right (+pos pos (pos speed 0)))))

(defun get-binding-val (key alist)
  "Gets the binding associated with key in alist."
  (cdr (assoc key alist)))

(defun update-alist (keys vals alist)
  "Updates the alist. Replaces keys (non-destructively) in alist with new vals."
  (pairlis keys vals (remove-if #'(lambda (key) (member key keys)) alist :key #'car)))

(move-pacman *pacman*)
;; => ((:POS . #S(POS :X 2099 :Y 2048)) (:SPEED . 51) (:DIR . :RIGHT))
*pacman*
;; => ((:SPEED . 51) (:DIR . :RIGHT) (:POS . #S(POS :X 2048 :Y 2048)))

;;; Looks good. Now let's put it in our timed loop and check it out in terminal.
(defun try-move-pacman ()
  (with-curses
      #'(lambda ()
	  (start-color)
	  (time-loop
	   #'(lambda ()
	       (setq *pacman* (move-pacman *pacman*))
	       (clearscr)
	       (draw-arena)
	       (draw-pacman-char :cp 0
				 :pos (sub-pixel-pos->tile-pos (get-binding-val :pos *pacman*))
				 :dir (get-binding-val :dir *pacman*)
				 :mouth-open? t)
	       (refresh))
	   :fps *frames/second*))))

(defun sub-pixel-pos->tile-pos (pos)
  "Convert a sub-pixel-pos to a valid tile-pos."
  (let ((divisor (* *pixels/tile* *sub-pixels/pixel*)))
    (pos (floor (px pos) divisor)
	 (floor (py pos) divisor))))

#+example
(run-in-terminal '(try-move-pacman))

;;; That feels slow
(setq *pacman-speed* (make-speed 3))

;;; That feels about right.
;;; Now I really want to be able to control his direction!

;;; Since terminal IO doesn't register key-releases, I'm going to have
;;; pacman always be moving. When the player wants to change directions,
;;; she'll press a key and pacman will change directions at the first
;;; opportunity.

;;; The only way to control Pac-Man is to change his direction, so
;;; keybindings are a straightforward mapping.

(defparameter *pacman-keybindings*
  (pairlis (list key_left key_right key_up key_down)
	   '(:left :right :up :down))
  "An alist of bindings from Ncurses key code to direction.")

(defun pacman-handle-inputs (inputs pacman)
  "Given a list of inputs, update pacman."
  (let ((binding (some (lambda (input) (assoc input *pacman-keybindings*))
		       (reverse inputs))))
    (if binding
	(update-alist '(:dir) (list (cdr binding)) pacman)
	pacman)))

#+example
(let* ((inputs (list key_right #\a #\b key_left))
       (binding (some (lambda (input) (assoc input *pacman-keybindings*))
		      (reverse inputs))))
  (if binding
      (cdr binding)))
;; => :LEFT

(defun try-pacman-inputs ()
  (with-curses-in-time-loop
      #'(lambda ()
	  (setq *pacman*
		(move-pacman
		 (pacman-handle-inputs (get-inputs) *pacman*)))
	  (with-fresh-render
	      #'(lambda ()
		  (draw-arena)
		  (draw-pacman *pacman*))))))

(defun with-curses-in-time-loop (fn &key (init-fn #'init-curses-settings) (fps *frames/second*) (quit-val :quit))
  "Runs a curses program in a time loop. Calls init-fn if it is provided"
  (with-curses
      #'(lambda ()
	  (when init-fn
	    (funcall init-fn))
	  (time-loop fn :fps fps :quit-val quit-val))))

(defun init-curses-settings ()
  "General settings for curses that only needs to be run once."
  (start-color)
  (keypad *stdscr* true)
  (noecho)
  (nodelay *stdscr* true)
  (curs-set false)
  (cbreak))

(defun with-fresh-render (fn)
  "Calls fn after clearing the screen, and refreshes the output after."
  (clearscr)
  (funcall fn)
  (refresh))

(defparameter *pacman-cp* 0 "The color pair associated with Pac-Man.")

(defun draw-pacman (pacman)
  "Draws pacman."
  (draw-pacman-char :cp *pacman-cp*
		    :pos (sub-pixel-pos->tile-pos (get-binding-val :pos pacman))
		    :dir (get-binding-val :dir pacman)
		    :mouth-open? (get-binding-val :mouth-open? pacman)))

;;; I'll also store whether the mouth is open as a part of pacman.
(setq *pacman* (update-alist '(:mouth-open?) '(t) *pacman*))
;; => ((:MOUTH-OPEN? . T) (:DIR . :RIGHT) (:POS . #S(POS :X 2048 :Y 2048)))

#+example
(run-in-terminal '(try-pacman-inputs))

;;; It works, but it's an error if pacman go off the edge of the screen.
;;; Really, he shouldn't be able to go through walls. Looks like its time for
;;; some collision detection.

;;; Collisions are measured from Pac-Man's center point.
;;; I'd like to properly visualize the situation.

;;;; Rendering at a Pixel Level

;;; It's not feasible to render pixels for gameplay (you couldn't see the whole board)
;;; so it'll be a debug view: and it will be focused on a tile.

;;; I think the easiest way to toggle this behavior is a layer between functions
;;; such as draw-arena/draw-pacman and putchar. This requires redefining those two:

(defun draw-arena (&optional (arena-cps '((:wall . 0) (:door . 0))))
  "Draws the arena with the given arena-cps alist.
arena-cps is an association from an arena-type
to a color-pair index."
  (loop
     for row from 0
     for str across *arena* do
       (loop
	  for col from 0
	  for char across str
	  when (member char *arena-chars*) do
	    (draw-tile char ; ***
		       (*pos (pos col row) *pixels/tile*)
		       (cdr (assoc (arena-char-type char) arena-cps))))))

;;; I'll provide a *render-target* so that I can move the camera around.

(defvar *render-target* (pos) "The tile to center the view around.")
(defvar *render-resolution* :tile "The resolution to render the view at, either tile or pixel.")

(defun draw-tile (char pixel-pos cp)
  "Draw a tile given the char, pixel-pos, and color-pair."
  (ecase *render-resolution*
    (:tile (putchar char (pos (floor (px pixel-pos) *pixels/tile*)
			      (floor (py pixel-pos) *pixels/tile*)) cp))
    (:pixel (draw-square-in-pixels char pixel-pos cp *render-target*))))

(defun draw-square-in-pixels (char pixel-pos cp center-tile-pos &key (size *pixels/tile*))
  "Renders the tile at pixel-pos, pixels filled with char,
while the view is centered at the center of center-tile-pos."
  (let* ((center-pixel-pos (*pos center-tile-pos *pixels/tile*))
	 (buffer-size (pos *buffer-width* *buffer-height*))
	 (top-left-pixel-pos (-pos center-pixel-pos
				   (*pos buffer-size 1/2)))
	 (bottom-right-pixel-pos (+pos top-left-pixel-pos buffer-size)))
    (loop
       for x from (px pixel-pos) below (+ (px pixel-pos) size)
       when (< (px top-left-pixel-pos) x (px bottom-right-pixel-pos))
       do
	 (loop
	    for y from (py pixel-pos) below (+ (py pixel-pos) size)
	    when (< (py top-left-pixel-pos) y (py bottom-right-pixel-pos)) do
	      (putchar char
		       (-pos (pos x y)
			     top-left-pixel-pos
			     (pos2 (* 1/2 *pixels/tile*)))
		       cp)))))

(defun -pos (p &rest ps)
  "Subtract ps from p. Return -p if no ps provided."
  (if (null ps)
      (pos (- (px p)) (- (py p)))
      (reduce #'(lambda (p1 p2)
		  (pos (- (px p1) (px p2))
		       (- (py p1) (py p2))))
	      ps
	      :initial-value p)))

(-pos (pos 3 4) (pos 2 1))
;; => #S(POS :X 1 :Y 3)
(-pos (pos 1 2))
;; => #S(POS :X -1 :Y -2)

#+example
(let* ((*buffer-width* 16)
       (*buffer-height* 16)
       (*draw-buffer* (create-empty-draw-buffer)))
  (draw-square-in-pixels #\O (pos 0 0) 0 (pos 0 0))
  (print-draw-buffer))

#+example
(let* ((*buffer-width* 16)
       (*buffer-height* 16)
       (*draw-buffer* (create-empty-draw-buffer)))
  (draw-square-in-pixels #\O (*pos (pos 1/2 -1/2) *pixels/tile*) 0 (pos 0 0) :size 4)
  (print-draw-buffer))

*pacman*
;; => ((:MOUTH-OPEN? . T) (:DIR . :RIGHT) (:POS . #S(POS :X 2048 :Y 2048)))

;;; For Pac-Man, I'd also like to be able to distinguish the center pixel.
;;; The center-point is used to determine which tile he is in.
;;; But looking ahead I'll probably want to do this for other entities as well.

(defun draw-entity (char pixel-pos cp &key (center-char char) (center-cp cp))
  "Draws an entity centered at pixel-pos.
With :pixel resolution, also draws the center pixel."
  (draw-tile char (-pos pixel-pos (pos2 (* 1/2 *pixels/tile*))) cp)
  (case *render-resolution*
    (:pixel (draw-square-in-pixels center-char
				   pixel-pos
				   center-cp
				   *render-target*
				   :size 1))))

(defun round-pos (p)
  "Rounds x and y."
  (pos (round (px p))
       (round (py p))))

(defun pos2 (v) "Returns (pos v v)" (pos v v))

(defparameter *pacman-center-cp* 0
  "The color pair representing pacman's center for debug.")

(defun draw-pacman (pacman)
  "Draws pacman."
  (draw-entity (pacman-char (get-binding-val :dir pacman)
			    (get-binding-val :mouth-open? pacman))
	       (*pos (get-binding-val :pos pacman) (/ *sub-pixels/pixel*))
	       *pacman-cp*
	       :center-char #\P
	       :center-cp *pacman-center-cp*))

;;; Now Pacman's pos will be his center, instead of his top-left.
(setq *pacman* (update-alist '(:pos)
			     (list (tile-pos (pos2 3/2)))
			     *pacman*))

#+example
(let ((*render-resolution* :pixel)
      (*render-target* (sub-pixel-pos->tile-pos (get-binding-val :pos *pacman*))))
  (clearscr)
  (draw-arena)
  (draw-pacman *pacman*)
  (print-draw-buffer))

;;; Rather than seeing if Pac-Man is colliding with a wall, and pushing
;;; him back out if he is, I'll ask how much room (if any) he has to move
;;; in a given direction.

(defun sub-pixels/tile ()
  (* *sub-pixels/pixel* *pixels/tile*))

(defun distance-to-wall (pos dir)
  "Given a sub-pixel position, determines how far it is from the
adjacent wall. If the adjacent tile isn't a wall, returns NIL"
  (let* ((tile-pos (sub-pixel-pos->tile-pos pos))
	 (wall-tile-pos (add-dir tile-pos dir)))
    (when (eq :wall (get-arena-tile-type wall-tile-pos))
      (dist1 (pos-along-dir pos dir)
	     (tile-edge wall-tile-pos
			(opposite-dir dir))))))

(defun add-dir (pos dir &optional (amount 1))
  "Adds AMOUNT units to POS in direction DIR."
  (ecase dir
    (:up (+pos pos (pos 0 (- amount))))
    (:down (+pos pos (pos 0 amount)))
    (:left (+pos pos (pos (- amount) 0)))
    (:right (+pos pos (pos amount 0)))))

(add-dir (pos 3 3) :up)
;; => #S(POS :X 3 :Y 2)

(defun dist1 (x y)
  "Returns the 1D distance between two values."
  (abs (- y x)))

(dist1 7 1)
;; => 6
(dist1 3 5)
;; => 2

(defun pos-along-dir (pos dir)
  "Returns the 1D position of POS along dir."
  (case dir
    ((:up :down) (py pos))
    (t (px pos))))

(pos-along-dir (pos 5 3) :up)
;; => 3
(pos-along-dir (pos 5 3) :right)
;; => 5

(defun opposite-dir (dir)
  "Returns the direction opposite dir."
  (ecase dir
    (:up :down)
    (:down :up)
    (:left :right)
    (:right :left)))

(opposite-dir :left)
;; => :RIGHT

(defun tile-edge (tile-pos dir)
  "Returns the 1D sub-pixel position of tile-pos in the direction of dir."
  (case dir
    ((:down :right)
     (pos-along-dir (tile-pos (add-dir tile-pos dir)) dir))
    (t (pos-along-dir (tile-pos tile-pos) dir))))

;; Where is the right edge of the tile at x=0, y=1?
(tile-edge (pos 0 1) :right)
;; => 2048
(* *sub-pixels/pixel* *pixels/tile*)
;; => 2048

(defun get-arena-tile-type (tile-pos)
  "Gets the tile-type associated with the tile-pos, or NIL
if tile-pos is not part of the arena."
  (let ((char (get-arena-tile-char tile-pos)))
    (when (member char *arena-chars*)
      (arena-char-type char))))

(defun get-arena-tile-char (tile-pos)
  "Gets the char at tile-pos."
  (aref (svref *arena* (py tile-pos))
	(px tile-pos)))

(get-arena-tile-type (pos 0 0))
;; => :WALL
(get-arena-tile-type (pos 1 1))
;; => NIL

;; How far is pacman from the wall if he is headed left?
(get-binding-val :pos *pacman*)
;; => #S(POS :X 3072 :Y 3072)
(sub-pixel-pos->tile-pos (get-binding-val :pos *pacman*))
;; => #S(POS :X 1 :Y 1)

(distance-to-wall (get-binding-val :pos *pacman*) :left)
;; => 1024
(distance-to-wall (get-binding-val :pos *pacman*) :right)
;; => NIL
(distance-to-wall (get-binding-val :pos *pacman*) :up)
;; => 1024

;;; Shoot, now that I'm thinking about it, corners DO need to be distinguished
;;; from walls, since Pac-Man can cut corners, while the ghosts cannot.

(defun arena-char-type (arena-char)
  "Look up the arena type associated with the arena-char."
  (ecase arena-char
    ((#\- #\|) :wall)
    (#\+ :corner)
    (#\_ :door)))

(defun move-entity (pos dir speed)
  "Moves an entity (ghost/pac-man) centered at pos.
If there is a wall blocking movement, restrict movement
so that there is at least 1/2 tile of space remaining.
Returns the new position."
  (let ((buffer (* 1/2 (sub-pixels/tile)))
	(dist (distance-to-wall pos dir)))
    (if (or (null dist) (< speed (- dist buffer)))
	(move-pos pos dir speed)
	(move-pos pos dir (- dist buffer)))))

(move-entity (get-binding-val :pos *pacman*) :left *pacman-speed*)
;; => #S(POS :X 3072 :Y 3072)
(move-entity (get-binding-val :pos *pacman*) :right *pacman-speed*)
;; => #S(POS :X 3174 :Y 3072)
(move-entity (get-binding-val :pos *pacman*) :up *pacman-speed*)
;; => #S(POS :X 3072 :Y 3072)

;;; Move-pacman should use move-entity now.

(defun move-pacman (pacman)
  "Move pacman in the direction he is facing by his speed for one frame."
  (let ((pos (get-binding-val :pos pacman))
	(dir (get-binding-val :dir pacman)))
    (update-alist '(:pos) (list (move-entity pos dir *pacman-speed*)) pacman)))

(defparameter *draw-arena-cps* '((:wall . 0) (:door . 0)
				 (:corner . 0))
  "Alist for arena types -> color-pair indices")

(defun try-pacman-wall-collisions ()
  (with-curses-in-time-loop
      #'(lambda ()
	  (setq *pacman*
		(move-pacman
		 (pacman-handle-inputs (get-inputs) *pacman*)))
	  (with-fresh-render
	      #'(lambda ()
		  (draw-arena *draw-arena-cps*)
		  (draw-pacman *pacman*))))))

#+example
(run-in-terminal '(try-pacman-wall-collisions))

;;; This obviously didn't work.

(defun debug-try-pacman-wall-collisions ()
  (let ((*render-resolution* :pixel))
    (with-curses-in-time-loop
	#'(lambda ()
	    (setq *pacman*
		  (move-pacman
		   (pacman-handle-inputs (get-inputs) *pacman*)))
	    (setq *render-target* (sub-pixel-pos->tile-pos
				   (get-binding-val :pos *pacman*)))

	    (with-fresh-render
		#'(lambda ()
		    (draw-arena *draw-arena-cps*)
		    (draw-pacman *pacman*)))))))

#+example
(run-in-terminal '(debug-try-pacman-wall-collisions))

;;; Oh, I see, I'm filling in the wrong tile. Also he's just whizzing through
;;; corners.

(defun draw-entity (char pixel-pos cp &key (center-char char) (center-cp cp))
  "Draws an entity with center at pixel-pos.
With :pixel resolution, also draws the center pixel."
  (draw-tile char pixel-pos cp)
  (case *render-resolution*
    (:pixel (draw-square-in-pixels center-char
				   pixel-pos
				   center-cp
				   *render-target*
				   :size 1))))

(defun draw-square-in-pixels (char pixel-pos cp center-tile-pos
			      &key (size *pixels/tile*))
  "Renders the tile that contains pixel-pos, filling it with char,
while the view is centered at the center of center-tile-pos."
  (let* ((center-pixel-pos (*pos center-tile-pos *pixels/tile*))
	 (buffer-size (pos *buffer-width* *buffer-height*))
	 (top-left-pixel-pos (-pos center-pixel-pos
				   (*pos buffer-size 1/2)))
	 (bottom-right-pixel-pos (+pos top-left-pixel-pos buffer-size))
	 (tile-pixel-pos (*pos (floor2 pixel-pos *pixels/tile*)
			       *pixels/tile*)))
    (loop
       for x from (px tile-pixel-pos) below (+ (px tile-pixel-pos) size)
       when (< (px top-left-pixel-pos) x (px bottom-right-pixel-pos))
       do
	 (loop
	    for y from (py tile-pixel-pos) below (+ (py tile-pixel-pos) size)
	    when (< (py top-left-pixel-pos) y (py bottom-right-pixel-pos)) do
	      (putchar char
		       (-pos (pos x y)
			     top-left-pixel-pos)
		       cp)))))

#+example
(run-in-terminal '(debug-try-pacman-wall-collisions))