;;; ;;; A logic puzzle game ;;; Copyright 2005 by Frank Buss (fb@frank-buss.de) ;;; CAPI cleanups by Dave Fox ;;; ;;; You can compile it with LispWorks. ;;; Call (start) to start the game. ;;; ;;; ;;; game logic ;;; ;; mapping between symbol and data file representation (defparameter *cell-types* '((:ground . #\.) (:channel . #\C) (:source . #\S) (:drain . #\D) (:player . #\P) (nil . #\Space))) ;; the 6 moving directions and opposite directions (defparameter *directions* '((-1 0 1 -1) (0 1 0 -1) (1 0 -1 -1) (-1 -1 1 0) (0 -1 0 1) (1 -1 -1 0))) ;; the game class (defclass aqueduct (capi:output-pane) ((pixmap :initform nil) (board :initform (make-array (list 0 0))) (board-template :initform (make-array (list 0 0))) (filled :initform (make-array (list 0 0))) (targets :initform (make-array (list 0 0))) (selected-cell-type :initform nil) (mode :initform :play) (source-selected :initform nil) (source-x) (source-y)) (:default-initargs :display-callback 'repaint :input-model '(((:button-1 :press) on-button-1-press) ((:button-3 :press) on-button-3-press) (:gesture-spec on-gesture)))) ;; copies an array (defun copy-array (array) (let ((dims (array-dimensions array))) (adjust-array (make-array dims :displaced-to array) dims))) ;; sets a cell on the board to the specified type (defmacro set-cell (board x y cell-type) `(setf (aref ,board ,y ,x) ,cell-type)) ;; checks, if the cell is of the specified type (defmacro is-cell (board x y cell-type) `(eql (aref ,board ,y ,x) ,cell-type)) ;; returns the with of the board (defun board-width (board) (cadr (array-dimensions board))) ;; returns the height of the board (defun board-height (board) (car (array-dimensions board))) ;; inits the board by a list of strings (defmethod init-board-template ((self aqueduct) lines) (with-slots (board-template) self (let ((width (reduce #'(lambda (x y) (max x (length y))) lines :initial-value 0)) (height (length lines))) (setf board-template (make-array (list height width))) (let ((y 0)) (dolist (line lines) (dotimes (x (length line)) (setf (aref board-template y x) (car (rassoc (elt line x) *cell-types*)))) (incf y)))))) ;; returns a list of coordinates of the specified cell type (defmethod find-all-cell-type ((self aqueduct) cell-type) (with-slots (board) self (let (coordinates) (dotimes (y (board-height board)) (dotimes (x (board-width board)) (when (is-cell board x y cell-type) (push (cons x y) coordinates)))) coordinates))) ;; returns the first occurence of the specified cell type (defmethod find-cell-type ((self aqueduct) cell-type) (let ((coordinates (find-all-cell-type self cell-type))) (when coordinates (destructuring-bind (x . y) (car coordinates) (values x y))))) ;; checks, if (x y) is a valid cell coordinate (defmethod is-valid ((self aqueduct) x y) (with-slots (board) self (let ((width (board-width board)) (height (board-height board))) (and x y (>= x 0) (< x width) (>= y 0) (< y height))))) ;; returns the next hexagon coordinates in direction (dx dy) (defun advance (x y dx dy) (incf y dy) (unless (zerop dx) (incf y (mod x 2)) (incf x dx)) (values x y)) ;; fills recursively all specified cell-types, starting at x y (defmethod flood-impl ((self aqueduct) x y cell-types) (with-slots (board filled) self (when (is-valid self x y) (when (and (not (aref filled y x)) (member (aref board y x) cell-types)) (setf (aref filled y x) t) (dolist (direction *directions*) (destructuring-bind (dx dy dx2 dy2) direction (declare (ignore dx2 dy2)) (multiple-value-bind (xp yp) (advance x y dx dy) (flood-impl self xp yp cell-types)))))))) ;; clears the fill array and fills all specified cell-types, starting at x y (defmethod flood ((self aqueduct) x y cell-types) (with-slots (board filled) self (setf filled (make-array (list (board-height board) (board-width board)))) (flood-impl self x y cell-types))) ;; moves the player and a channel, if pushed (defmethod on-move ((self aqueduct) dx dy) (with-slots (board) self (multiple-value-bind (x y) (find-cell-type self :player) (let ((old-x x) (old-y y)) (multiple-value-setq (x y) (advance x y dx dy)) (when (is-valid self x y) (if (is-cell board x y :ground) (progn (set-cell board old-x old-y :ground) (set-cell board x y :player)) (when (is-cell board x y :channel) (multiple-value-bind (x2 y2) (advance x y dx dy) (when (and (is-valid self x2 y2) (is-cell board x2 y2 :ground)) (set-cell board old-x old-y :ground) (set-cell board x y :player) (set-cell board x2 y2 :channel))))) (draw-aqueduct self)))))) ;;; ;;; game GUI ;;; ;; the edge with of a hexagon (defparameter *cell-width* 15) ;; p0____p1 ;; / \ | ;; / \ | ;; /p5 \p2 | e = sqr(3)*a ;; \ / | ;; \ / | ;; p4\__a___/p3 | ;; ____________ ;; d = 2*a ;; ___ ;; o = (d-a)/2 (defun get-hex-lines (x y) (let* ((a *cell-width*) (d (* 2 a)) (e (* (sqrt 3) a)) (o (/ (- d a) 2)) (x0 (+ o (* (+ a o) x))) (y0 (+ (* (mod x 2) (/ e 2)) (* y e))) (x1 (+ x0 a)) (y1 y0) (x2 (+ x1 o)) (y2 (+ y1 (/ e 2))) (x3 x1) (y3 (+ y0 e)) (x4 x0) (y4 y3) (x5 (- x0 o)) (y5 y2)) (list x0 y0 x1 y1 x2 y2 x3 y3 x4 y4 x5 y5))) ;; returns the center of the specified hexagon (defun get-hex-center (x y) (let* ((a *cell-width*) (d (* 2 a)) (e (* (sqrt 3) a)) (o (/ (- d a) 2))) (values (+ o (* (+ a o) x) (/ a 2)) (+ (* (mod x 2) (/ e 2)) (* y e) (/ e 2))))) ;; converts screen position to hexagon position (defmethod mouse-to-cell-coordinates ((self aqueduct) x y) (with-slots (board) self (dotimes (yb (board-height board)) (dotimes (xb (board-width board)) (let* ((a *cell-width*) (d (* 2 a)) (e (* (sqrt 3) a)) (o (/ (- d a) 2)) (x0 (+ o (* (+ a o) xb))) (y0 (+ (* (mod xb 2) (/ e 2)) (* yb e))) (center-x (+ x0 (/ a 2))) (center-y (+ y0 (/ e 2))) (dx (- x center-x)) (dy (- y center-y)) (dx2 (* dx dx)) (dy2 (* dy dy)) (e2 (/ e 2)) (e2 (* e2 e2))) (when (<= (+ dx2 dy2) e2) (return-from mouse-to-cell-coordinates (values xb yb)))))))) (defmethod is-something-filled-around ((self aqueduct) x y) (with-slots (board filled) self (dolist (direction *directions*) (destructuring-bind (dx dy dx2 dy2) direction (declare (ignore dx2 dy2)) (multiple-value-bind (xf yf) (advance x y dx dy) (when (and (is-valid self xf yf) (aref filled yf xf)) (return-from is-something-filled-around t))))))) ;; first checks, if route to source is possible, ;; then moves the player to it, if empty or ;; selects the source, if it is a channel (defmethod on-select-source ((self aqueduct) x y) (with-slots (board source-x source-y source-selected filled) self (multiple-value-bind (xp yp) (find-cell-type self :player) (flood self xp yp '(:player :ground)) (cond ((is-cell board x y :ground) (when (aref filled y x) (set-cell board xp yp :ground) (set-cell board x y :player))) ((is-cell board x y :channel) (when (is-something-filled-around self x y) (setf source-x x) (setf source-y y) (setf source-selected t))))))) (defmethod get-possible-targets-impl ((self aqueduct) targets xp yp xc yc) (with-slots (board source-x source-y source-selected filled mode) self (set-cell board xp yp :player) (set-cell board xc yc :channel) (flood self xp yp '(:player :ground)) (let ((filled (copy-array filled))) (set-cell board xp yp :ground) (set-cell board xc yc :ground) (dolist (direction *directions*) (destructuring-bind (dx dy dx2 dy2) direction (multiple-value-bind (xf yf) (advance xc yc dx dy) (when (and (is-valid self xf yf) (aref filled yf xf)) (if (eql mode :play) (multiple-value-bind (xt yt) (advance xc yc dx2 dy2) (when (and (is-valid self xt yt) (not (aref targets yt xt)) (is-cell board xt yt :ground)) (setf (aref targets yt xt) (cons xc yc)) (get-possible-targets-impl self targets xc yc xt yt))) (multiple-value-bind (xt yt) (advance xf yf dx dy) (when (and (is-valid self xt yt) (not (aref targets yf xf)) (is-cell board xt yt :ground)) (setf (aref targets yf xf) (cons xt yt)) (get-possible-targets-impl self targets xt yt xf yf))))))))))) (defmethod get-possible-targets ((self aqueduct)) (with-slots (board source-x source-y source-selected filled targets) self (multiple-value-bind (xp yp) (find-cell-type self :player) (setf targets (make-array (list (board-height board) (board-width board)))) (get-possible-targets-impl self targets xp yp source-x source-y) (set-cell board xp yp :player) (set-cell board source-x source-y :channel)))) (defmethod on-select-target ((self aqueduct) x y) (with-slots (board source-x source-y source-selected targets) self (when (not (and (= x source-x) (= y source-y))) (get-possible-targets self) (when (aref targets y x) (multiple-value-bind (xp yp) (find-cell-type self :player) ; (when (not (and (= xp x) (= yp y))) (set-cell board xp yp :ground) (set-cell board source-x source-y :ground) (destructuring-bind (xp . yp) (aref targets y x) (set-cell board xp yp :player)) (set-cell board x y :channel)))) (setf source-selected nil))) ;; called on button 1 press in play mode (defmethod on-play-button-1-press ((self aqueduct) x y) (with-slots (source-selected) self (if source-selected (on-select-target self x y) (on-select-source self x y)))) ;; called on button 1 press in edit mode (defmethod on-edit-button-1-press ((self aqueduct) x y) (with-slots (board selected-cell-type) self (when selected-cell-type (when (or (eql selected-cell-type :source) (eql selected-cell-type :player)) (multiple-value-bind (xs ys) (find-cell-type self selected-cell-type) (when (is-valid self xs ys) (set-cell board xs ys :ground)))) (set-cell board x y selected-cell-type)))) ;; called on button 1 press (defmethod on-button-1-press ((self aqueduct) x y) (with-slots (board selected-cell-type mode) self (multiple-value-bind (px py) (mouse-to-cell-coordinates self x y) (when (is-valid self px py) (if (or (eql mode :play) (eql selected-cell-type :back)) (on-play-button-1-press self px py) (on-edit-button-1-press self px py)) (draw-aqueduct self))))) ;; clears a cell (defmethod on-button-3-press ((self aqueduct) x y) (with-slots (board) self (multiple-value-bind (px py) (mouse-to-cell-coordinates self x y) (when (is-valid self px py) (setf (aref board py px) nil) (draw-aqueduct self))))) ;; draws a hexagon outline with black (defmethod draw-hex-outline ((self aqueduct) x y) (with-slots (pixmap) self (gp:set-graphics-state pixmap :foreground :black) (gp:draw-polygon pixmap (get-hex-lines x y) :closed t))) ;; fills a hexagon outline with the current color (defmethod draw-hex-fill ((self aqueduct) x y) (with-slots (pixmap) self (gp:draw-polygon pixmap (get-hex-lines x y) :closed t :filled t))) ;; draws a ground cell (defmethod draw-ground ((self aqueduct) x y) (with-slots (source-selected source-x source-y filled targets pixmap) self (gp:set-graphics-state pixmap :foreground (if (and source-selected (or (and (= source-x x) (= source-y y)) (aref targets y x))) :yellow :gray)) (draw-hex-fill self x y))) ;; draws a player (defmethod draw-player ((self aqueduct) x y) (with-slots (pixmap) self (draw-ground self x y) (multiple-value-bind (x0 y0) (get-hex-center x y) (gp:set-graphics-state pixmap :foreground :red) (gp:draw-circle pixmap x0 y0 (/ *cell-width* 2) :filled t)))) ;; draws a source (defmethod draw-source ((self aqueduct) x y) (with-slots (pixmap) self (draw-ground self x y) (multiple-value-bind (x0 y0) (get-hex-center x y) (gp:set-graphics-state pixmap :foreground :white) (gp:draw-circle pixmap x0 y0 (/ *cell-width* 2) :filled t)))) ;; draws a drain (defmethod draw-drain ((self aqueduct) x y) (with-slots (pixmap) self (draw-ground self x y) (multiple-value-bind (x0 y0) (get-hex-center x y) (gp:set-graphics-state pixmap :foreground :green) (gp:draw-circle pixmap x0 y0 (/ *cell-width* 2) :filled t)))) ;; draws a channel (defmethod draw-channel ((self aqueduct) x y) (draw-ground self x y) (with-slots (filled pixmap) self (multiple-value-bind (xc yc) (get-hex-center x y) (gp:set-graphics-state pixmap :foreground (if (aref filled y x) :blue :black)) (gp:draw-circle pixmap xc yc (/ *cell-width* 2) :filled t) (destructuring-bind (x0 y0 x1 y1 x2 y2 x3 y3 x4 y4 x5 y5) (get-hex-lines x y) (gp:draw-line pixmap xc yc (/ (+ x0 x1) 2) (/ (+ y0 y1) 2)) (gp:draw-line pixmap xc yc (/ (+ x1 x2) 2) (/ (+ y1 y2) 2)) (gp:draw-line pixmap xc yc (/ (+ x2 x3) 2) (/ (+ y2 y3) 2)) (gp:draw-line pixmap xc yc (/ (+ x3 x4) 2) (/ (+ y3 y4) 2)) (gp:draw-line pixmap xc yc (/ (+ x4 x5) 2) (/ (+ y4 y5) 2)) (gp:draw-line pixmap xc yc (/ (+ x4 x5) 2) (/ (+ y4 y5) 2)) (gp:draw-line pixmap xc yc (/ (+ x5 x0) 2) (/ (+ y5 y0) 2)))))) ;; draws all hexagons (defmethod draw-aqueduct ((self aqueduct)) (with-slots (board filled pixmap source-selected) self (when (null pixmap) (setf pixmap (gp:create-pixmap-port self 600 500 :clear t :background :white))) (gp:clear-graphics-port pixmap) (when source-selected (get-possible-targets self)) (multiple-value-bind (x y) (find-cell-type self :source) (flood self x y '(:source :drain :channel))) (dotimes (y (board-height board)) (dotimes (x (board-width board)) (when (is-cell board x y :ground) (draw-ground self x y)) (when (is-cell board x y :source) (draw-source self x y)) (when (is-cell board x y :drain) (draw-drain self x y)) (when (is-cell board x y :channel) (draw-channel self x y)) (when (is-cell board x y :player) (draw-player self x y)) (draw-hex-outline self x y))) (let ((drains (find-all-cell-type self :drain)) (count 0)) (dolist (drain drains) (destructuring-bind (x . y) drain (when (aref filled y x) (incf count)))) (when (= count (length drains)) (gp:set-graphics-state pixmap :foreground :red :font (gp:find-best-font self (gp:make-font-description :family "times" :weight :bold :size 24))) (gp:draw-string pixmap "You have won!" 100 100))) (gp:pixblt self boole-1 pixmap 0 0 600 500 0 0))) ;; is called on repaint events (defmethod repaint ((self aqueduct) x y width height) (declare (ignore x y width height)) (draw-aqueduct self)) (defparameter *test* '(" " " " " " " " " S " " .. C " " C..C.C " " .C .PC. " " .. .C.. " " C.... " " DC D " " " " " " " " " " ")) ;; a solution for *test*: 341331144545633344412653362213 ;; loads a new map template (defmethod on-load ((self aqueduct)) (multiple-value-bind (filename res) (capi:prompt-for-file "Load File" :operation :open) (when res (with-open-file (in filename) (init-board-template self (loop for line = (read-line in nil) while line collect line))) (on-play self) (draw-aqueduct self)))) ;; saves the current map template (defmethod on-save ((self aqueduct)) (with-slots (board-template) self (multiple-value-bind (filename res) (capi:prompt-for-file "Save File" :operation :save) (when res (with-open-file (out filename :direction :output :if-exists :supersede) (dotimes (y (board-height board-template)) (dotimes (x (board-width board-template)) (princ (cdr (assoc (aref board-template y x) *cell-types*)) out)) (terpri out))))))) ;; sets the current displayed map to the map template (defmethod on-edit ((self aqueduct)) (with-slots (board-template board mode) self (setf mode :edit) (setf board board-template) (draw-aqueduct self))) ;; copies the map template and sets the copy to the current displayed map (defmethod on-play ((self aqueduct)) (with-slots (board-template board mode source-selected) self (setf mode :play) (setf source-selected nil) (setf board (copy-array board-template)) (draw-aqueduct self))) ;; changes the cell type to the special type :back (defmethod on-back ((self aqueduct)) (setf (slot-value self 'selected-cell-type) :back)) ;; changes the cell type on left mouse click to :ground (defmethod on-ground ((self aqueduct)) (setf (slot-value self 'selected-cell-type) :ground)) ;; changes the cell type on left mouse click to :channel (defmethod on-channel ((self aqueduct)) (setf (slot-value self 'selected-cell-type) :channel)) ;; changes the cell type on left mouse click to :source (defmethod on-source ((self aqueduct)) (setf (slot-value self 'selected-cell-type) :source)) ;; changes the cell type on left mouse click to :drain (defmethod on-drain ((self aqueduct)) (setf (slot-value self 'selected-cell-type) :drain)) ;; changes the cell type on left mouse click to :player (defmethod on-player ((self aqueduct)) (setf (slot-value self 'selected-cell-type) :player)) ;; shows a help text (defmethod on-help ((self aqueduct)) (capi:display-message "Aqueduct V 0.4 You are the red circle. Move with the number keys: 1: bottom left 2: bottom 3: bottom right 4: top left 5: top 6: top right You can move with the mouse, to. Just click in an empty field to move, or you can click a channel and then all possible destinations are calculated, which you can select with a second click. If you want to select another source, click again a channel. The goal is to connect all green circles to the white circle by moving around the channel pieces. A solution for the initial displayed map: 341331144545633344412653362213 Load: Loads a level and starts the play mode. Every time you click on 'Play', the loaded level is restored. Save: Saves an edited level. Edit: Switches to edit mode. Select the piece you want to place by clicking to 'Ground', 'Channel', 'Source', 'Drain' or 'Player' and place it by left clicking in the map. Right click deletes a piece. You can test the level by clicking on 'Play'. If you want to change it, click again on 'Edit'. If you select 'Back', you can move backward in edit mode by mouse clicking.")) ;; the aqueduct game interface (capi:define-interface aqueduct-interface () ((buttons :initform '(("Load" on-load) ("Save" on-save) ("Play" on-play) ("Edit" on-edit) ("Back" on-back) ("Ground" on-ground) ("Channel" on-channel) ("Source" on-source) ("Drain" on-drain) ("Player" on-player) ("Help" on-help)))) (:panes (aqueduct aqueduct) (push-button-panel capi:push-button-panel :interaction :spring-loaded :layout-class 'capi:row-layout :callbacks (mapcar #'(lambda (button) (lambda (data interface) (declare (ignore data interface)) (funcall (cadr button) aqueduct) (capi:set-pane-focus aqueduct))) buttons) :items (mapcar #'car buttons))) (:layouts (column capi:column-layout '(push-button-panel aqueduct) :initial-focus 'aqueduct :gap 1 :x-adjust :centre)) (:default-initargs :title "Aqueduct" :width 600 :height 500)) ;; initialization after interface construction (defmethod capi:interface-display :after ((self aqueduct-interface)) (with-slots (aqueduct) self (defparameter *a* aqueduct) (init-board-template aqueduct *test*) (on-play aqueduct) (draw-aqueduct aqueduct) (capi:set-pane-focus aqueduct))) ;; key handling (defmethod on-gesture ((self aqueduct) x y gspec) (let ((direction (#+LispWorks4.3 sys::gesture-spec-data #-LispWorks4.3 sys:gesture-spec-data gspec))) (when (numberp direction) (if (>= direction 97) (decf direction 97) (when (>= direction 49) (decf direction 49))) (when (and (>= direction 0) (<= direction 5)) (princ direction) (destructuring-bind (dx dy dx2 dy2) (elt *directions* direction) (declare (ignore dx2 dy2)) (on-move self dx dy)))))) ;; starts the game (defun start () (capi:display (make-instance 'aqueduct-interface)))