Skip to content

Instantly share code, notes, and snippets.

@alex-hhh
Created July 2, 2020 06:26
Show Gist options
  • Save alex-hhh/2e204b3a9d9d7094f65a0b585d0b7480 to your computer and use it in GitHub Desktop.
Save alex-hhh/2e204b3a9d9d7094f65a0b585d0b7480 to your computer and use it in GitHub Desktop.
Ishido Game Impementation
#lang racket
;; Ishido Game Implementation
;; Copyright (c) 2020 Alex Harsányi (AlexHarsanyi@gmail.com)
;; Permission is hereby granted, free of charge, to any person obtaining a
;; copy of this software and associated documentation files (the "Software"),
;; to deal in the Software without restriction, including without limitation
;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;; and/or sell copies of the Software, and to permit persons to whom the
;; Software is furnished to do so, subject to the following conditions:
;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;; DEALINGS IN THE SOFTWARE.#lang racket
(require racket/draw pict racket/gui)
;; The Ishido game is played on a 8x12 board with 72 tiles. There are six
;; colors and six images which combined produce 36 unique tiles and there are
;; two of each tile in the playing set. The objective of the game is to place
;; the tiles on the board with the following rules:
;;
;; * a tile must be placed next to one or more tiles
;;
;; * a tile can be placed next to another one if either their color or image
;; match. If there are multiple tiles around the tile, each neighbor must
;; match either the color or the image.
;;
;; The game starts with the first six tiles already on the board, one in each
;; corner and two in the middle. The tiles are selected such that each
;; possible color and each possible image is present on the board, thus
;; ensuring that the very first tile can be placed on the board.
;;
;; Scoring is done to reflect the complexity of the placement, with 1 point
;; awarded if a tile is placed next to a single tile, 2 points for placing it
;; against two tiles, 4 points for placing it against 3 neighbors and 8 points
;; for placing it against 4.
;;
;; The game ends when either there are no more tiles to be placed on the board
;; or there is no valid location on which to place a tile.
;;............................................................ Locations ....
;; The playing board is always 8x12
(define-values (board-rows board-columns) (values 8 12))
;; Guard procedure attached to the location struct to ensure that all location
;; objects have valid values
(define (location-guard column row struct-name)
(cond ((not (and (number? column) (number? row)))
(error "~a: both column and row must be numbers, got ~a, ~a"
struct-name column row))
((or (< column 0) (>= column board-columns))
(error (format "~a: bad column, ~a, should be between ~a and ~a"
struct-name column 0 (sub1 board-columns))))
((or (< row 0) (>= row board-rows))
(error (format "~a: bad row, ~a, should be between ~a and ~a"
struct-name row 0 (sub1 board-rows)))))
(values column row))
;; Stores the location of a piece on the board
(struct location (column row) #:guard location-guard #:transparent)
;; Return a list of neighboring locations for L. These are the locations to
;; the North, South, East and West of the current location, except positions
;; which would be off the board are not included.
(define (neighbour-locations l)
(match-define (location column row) l)
(define result '())
(when (< (add1 row) board-rows)
(set! result (cons (location column (add1 row)) result)))
(when (>= (sub1 row) 0)
(set! result (cons (location column (sub1 row)) result)))
(when (< (add1 column) board-columns)
(set! result (cons (location (add1 column) row) result)))
(when (>= (sub1 column) 0)
(set! result (cons (location (sub1 column) row) result)))
result)
;; Initial locations for the tiles on the board at the start of the game. The
;; first 6 tiles from a new pouch will be placed in these positions.
(define initial-locations
(list
(location 0 0)
(location 11 0)
(location 5 3)
(location 6 4)
(location 0 7)
(location 11 7)))
;;................................................................. Keys ....
;; Tiles in the game have two important attributes, their color and the symbol
;; printed on them. To avoid confusion, this code will use color to always
;; refer to a RGB color, and glyph to refer to a character or string. The
;; word "symbol" is also taken by Racket to mean something else. This is why
;; we use "material" and "sigil".
;;
;; For the code logic itself, we'll use the word MATERIAL (a number between 0
;; and 5 inclusive) to refer to the tile color and SIGIL (a number between 0
;; and 5) to refer to the symbol printed on tile. We encapsulate the material
;; and sigil in a key structure which gives identity to each tile.
;; Guard procedure attached to the key struct ensuring objects have valid
;; values
(define (key-guard material sigil struct-name)
(cond ((not (and (number? material) (number? sigil)))
(error "~a: both material and sigil must be numbers, got ~a, ~a"
struct-name material sigil))
((or (< material 0) (>= material 6))
(error (format "~a: bad material, ~a, should be between ~a and ~a"
struct-name material 0 5)))
((or (< sigil 0) (>= sigil 6))
(error (format "~a: bad sigil, ~a, should be between ~a and ~a"
struct-name sigil 0 5))))
(values material sigil))
;; Stores the key of a tile, its material and sigil -- this defines the
;; "identity" of a tile
(struct key (material sigil) #:guard key-guard #:transparent)
;; Return true if key1 and key2 can be placed next to each other -- they can
;; be neighbors if either their material (color) or sigil (glyph) are the
;; same.
(define (can-be-neighbors? key1 key2)
(match-define (key material1 sigil1) key1)
(match-define (key material2 sigil2) key2)
(or (equal? material1 material2) (equal? sigil1 sigil2)))
;;.................................................... drawing resources ....
;; The racket/draw framework uses various resources for drawing: pens, brushes
;; and fonts. `the-brush-list`, `the-pen-list` and `the-font-list` keep these
;; resources in a hash table to be reused, but it is simpler to create them
;; here and refer to them by name. Their name is also shorter than the
;; "the-*-list" invocation.
(define transparent-brush (send the-brush-list find-or-create-brush "white" 'transparent))
(define shade-brush (send the-brush-list find-or-create-brush "gray" 'crossdiag-hatch))
(define transparent-pen (send the-pen-list find-or-create-pen "black" 0 'transparent))
(define info-font (send the-font-list find-or-create-font 12 'default 'normal 'normal))
(define pen (send the-pen-list find-or-create-pen "Dark Slate Gray" 2 'solid))
(define highlight-pen (send the-pen-list find-or-create-pen "LightCoral" 3 'solid))
(define valid-location-pen (send the-pen-list find-or-create-pen "steelblue" 3 'solid))
(define message-brush (send the-brush-list find-or-create-brush (make-color 200 200 200 0.9) 'solid))
(define message-font (send the-font-list find-or-create-font 54 'default 'normal 'normal))
;; Draw a message in the middle of the drawing context DC. A rectangle is
;; drawn using `message-brush` and the `message-font` is used for drawing.
;; This is currently used to print the game over message at the end of the
;; game.
(define (draw-centered-message dc message)
(define-values (width height baseline extra-space)
(send dc get-text-extent message message-font #t))
(define-values (dc-width dc-height)
(send dc get-size))
(define border 5)
(send dc set-pen transparent-pen)
(send dc set-brush message-brush)
(send dc draw-rectangle
(- (/ (- dc-width width) 2) border)
(- (/ (- dc-height height) 2) border)
(+ width border border)
(+ height border border))
(send dc set-text-foreground "IndianRed")
(send dc set-font message-font)
(send dc draw-text message (/ (- dc-width width) 2) (/ (- dc-height height) 2)))
;;............................................................... theme% ....
;; The Theme class encapsulates the colors and glyphs used for rendering the
;; tiles. Each tile will reference the current theme and will ask it for the
;; drawing resource corresponding to its key. The theme also stores the cell
;; width and height, which changes when the board is resized (for example
;; because the window is resized).
(define theme%
(class object%
;; COLORS is a vector of 6 unique colors used for the tules, GLYPHS is a
;; string of 6 unicode characters, one for each tile. While not
;; implemented here, the colors and glyphs could be changed at runtime and
;; the board would immediately reflect the theme change.
(init-field colors glyphs)
(super-new)
(define cell-width 30)
(define cell-height 50)
(define font (send the-font-list find-or-create-font 18 'default 'normal 'normal))
(define glyph-dimensions #f)
;; Return the color corresponding to a tile KEY (a key structure instance)
(define/public (get-color key)
(vector-ref colors (key-material key)))
;; Return a brush with the color corresponding to a tile KEY (a key
;; structure). This will be used by the tile snip to draw its tile.
(define/public (get-brush-for-material key)
(define color (get-color key))
(send the-brush-list find-or-create-brush color 'solid))
;; Return the GLYPH corresponding to a tile KEY (a key structure)
(define/public (get-glyph key)
(string (string-ref glyphs (key-sigil key))))
;; Return the font used to draw the glyphs -- while not implemented here,
;; the font size could be adjusted when the cell size changes, and the
;; images on the tiles would scale with the tile (they don't currently).
(define/public (get-font)
font)
;; Return the color used for rendering the glyph.
(define/public (get-text-foreground)
"whitesmoke")
;; Return the width and height of the glyph corresponding to a tile KEY (a
;; key structure). This is used by the tile snip to draw the glyph in the
;; middle of its drawing area.
(define/public (get-glyph-size dc key)
(unless glyph-dimensions
(set! glyph-dimensions (setup-glyph-dimensions dc font)))
(match-define (cons glyph-width glyph-height)
(vector-ref glyph-dimensions (key-sigil key)))
(values glyph-width glyph-height))
;; Return the dimensions of each tile.
(define/public (get-cell-size)
(values cell-width cell-height))
;; Set the dimensions of each tile -- this is called by the editor canvas
;; when its size changes.
(define/public (set-cell-size w h)
(set! cell-width w)
(set! cell-height h)
(set! glyph-dimensions #f))
;; Setup the glyph dimensions -- these are calculated once, and reused
(define/private (setup-glyph-dimensions dc font)
(for/vector ([glyph (in-string glyphs)])
(define-values (width height baseline extra-space)
(send dc get-text-extent (string glyph) font #t))
(cons width height)))
))
;;................................................................ tile% ....
;; Each snip needs to have a snip class defined. This handles snip
;; serialization and de-serialization. We don't use these features in this
;; game, and we don't define any read and write functions, but a snip class
;; still needs to be defined. Also note that the snip class is actually an
;; object of type `snip-class%`.
(define ishido-tile-snip-class
(make-object
(class snip-class%
(super-new)
(send this set-classname "ishido-tile-snip"))))
;; Register our snip class with the system.
(send (get-the-snip-class-list) add ishido-tile-snip-class)
;; A tile is a snip% which will be managed by a pasteboard. Being a snip, the
;; dragging and moving of it will be handled by the pasteboard, we only need
;; to define the drawing method.
(define tile%
(class snip%
;; A tile is initialized with a KEY (a key struct) which gives its
;; identity and a THEME which defines how it is drawn. A tile also has a
;; location. This is not used directly by this class, but it will be set
;; and retrieved by the pasteboard itself.
(init-field key theme [location #f])
(super-new)
;; Tell the system that this snip has the "ishido-tile-snip-class".
(send this set-snipclass ishido-tile-snip-class)
(define/public (get-location)
location)
(define/public (set-location l)
(set! location l))
(define/public (get-key) key)
;; The GET-EXTENT method defines the size of the snip. There are many
;; arguments to this method, since the snip class supports a size which is
;; dependent on its location (X, Y) and the snip can represent text, in
;; which case it can also specify the amount of space around it. Our tile
;; is a simple rectangle, so we set the with and height, and the remaining
;; parameters to 0. Our size is also independent of the snip location, so
;; we ignore the X, Y parameters.
;;
;; Note that the W, H, DESCENT, SPACE, LSPACE, RSPACE are boxes, which
;; means that they are "output" parameters and we set values using
;; `set-box!`
(define/override (get-extent dc x y w h descent space lspace rspace)
(define-values (width height) (send theme get-cell-size))
(when w (set-box! w width))
(when h (set-box! h height))
(when descent (set-box! descent 0.0))
(when space (set-box! space 0.0))
(when lspace (set-box! lspace 0.0))
(when rspace (set-box! rspace 0.0)))
;; Draw the current tile on the drawing context DC at location X, Y. The
;; draw method has other arguments which we ignore (they allow redrawing
;; just a subset of the tile, but we always draw the tile in full).
(define/override (draw dc x y . other)
(define-values (width height) (send theme get-cell-size))
(define brush (send theme get-brush-for-material key))
(send dc set-brush brush)
(send dc set-pen transparent-pen)
(send dc draw-rounded-rectangle x y width height)
(send dc set-font (send theme get-font))
(send dc set-text-foreground (send theme get-text-foreground))
(define-values (glyph-width glyph-height) (send theme get-glyph-size dc key))
(let ((ox (/ (- width glyph-width) 2))
(oy (/ (- height glyph-height) 2)))
(send dc draw-text (send theme get-glyph key) (+ x ox) (+ y oy))))
))
;;....................................................... make-new-pouch ....
;; Prepare a new pouch of game tiles for play. The `theme` is used to
;; initialize `tile%` objects. The returned "pouch" is a list of `tile%`
;; objects as follows:
;;
;; * there are 72 tiles in the pouch: two of every material + sigil
;; combination (there are 6 materials and 6 sigils, making 36 unique
;; combinations)
;;
;; * the tiles are in random order (randomized using the `shuffle` function),
;; but the first 6 tiles in the list are all unique materials + sigil
;; combinations. This means that there are 6 distinct materials and 6
;; distinct sigils in the first 6 tiles -- they will be used to initialize the
;; board and ensure that the next tile can be placed somewhere on the board.
(define (make-pouch theme)
;; Step 1: generate a list of 72 tiles, two of each material + sigil
;; combination.
(define all
(for*/list ([group (in-range 2)]
[material (in-range 6)]
[sigil (in-range 6)])
(new tile% [key (key material sigil)] [theme theme])))
;; Step 2: shuffle the tiles, so the are in a random order
(define shuffled (shuffle all))
;; Step 3: Bring to the front of the list the first 6 tiles with unique
;; materials and sigils
(let loop ([remaining shuffled]
[head '()] ; contains unique material + sigil tiles
[tail '()] ; contains all other tiles
;; materials we haven't seen yet
[materials (for/list ([x (in-range 6)]) x)]
;; sigils we haven't seen yet
[sigils (for/list ([x (in-range 6)]) x)])
(cond ((null? remaining)
(append head tail))
((and (null? materials) (null? sigils))
;; We have seen all materials and sigils
(append head tail remaining))
(#t
(let ([candidate (car remaining)])
(match-define (key material sigil) (send candidate get-key))
(if (and (member material materials)
(member sigil sigils))
(loop (cdr remaining)
(cons candidate head)
tail
(remove material materials)
(remove sigil sigils))
(loop (cdr remaining)
head
(cons candidate tail)
materials
sigils)))))))
;;............................................................... board% ....
;; A list of locations which show up "shaded" on the board. These don't
;; represent anything in the game, but makes the board look nicer.
(define shaded-locations
(append
(for/list ([column (in-range 1 11)])
(location column 0))
(for/list ([column (in-range 1 11)])
(location column 7))
(for/list ([row (in-range 1 7)])
(location 0 row))
(for/list ([row (in-range 1 7)])
(location 11 row))
(list
(location 5 3)
(location 6 4))))
;; This is the game board -- it is a pasteboard% which manages tiles and
;; determines the game rules. This is no "Model View Controller" design --
;; both the game logic and drawing is in this class :-)
(define board%
(class pasteboard%
(init-field theme)
(super-new)
;; A list of tiles that remain to be placed on the board. Originally this
;; starts out as the list from `make-pouch`, and we remove lists from here
;; when we need a new tile. Note that these tiles are not yet "inserted"
;; into the pasteboard%, so they are not visible to the user.
;;
;; The `pasteboard%` itself will manage the tiles that are visible (to
;; make a tile visible we use the insert method).
(define pouch '())
;; The current game score
(define score 0)
;; A location which should be highlighted -- when dragging tiles, we
;; determine where the tile would be dropped and store it here. The
;; drawing code will use this location to highlight the square on which
;; the tile would be placed when dropped.
(define highlight-location #f)
;; A list of locations where the current tile can be dropped. When this
;; is empty, its game over. Normally, we won't show this to the user, but
;; this game will use items in this list to draw the score of each drop
;; location during the game -- this is cheating, but the aim here is to
;; learn programming not to play the game -- besides, you can just disable
;; the drawing code.
(define valid-drop-locations '())
;; When #t the game is over, either because the pouch is empty or because
;; there are no valid locations to place the current tile.
(define game-over? #f)
;; When #t, the user won, that is they placed all the tiles on the board.
(define winning? #f)
;; These are the origin and dimensions of the board -- note that it does
;; not cover the entire canvas.
(define-values (board-x board-y board-width board-height)
(values 0 0 0 0))
;; These are the origin and dimensions of the square where the next tile
;; is placed.
(define-values (next-tile-x next-tile-y next-tile-width next-tile-height)
(values 0 0 0 0))
;; Convert canvas coordinates X, Y into a location object on the board, or
;; return #f if X, Y are outside the board area.
;;
;; NOTE that we adjust for the X, Y coordinates for the horizontal and
;; vertical inset of the canvas
(define/private (xy->location x y)
(define canvas (send this get-canvas))
(define-values (cell-width cell-height) (send theme get-cell-size))
(define adjusted-x (- x board-x (send canvas horizontal-inset)))
(define adjusted-y (- y board-y (send canvas vertical-inset)))
(define column (exact-truncate (/ adjusted-x cell-width)))
(define row (exact-truncate (/ adjusted-y cell-height)))
(if (and (< row board-rows) (< column board-columns))
(location column row)
;; The X, Y coordinates are not on the board
#f))
;; Convert a location L to the X, Y coordinates of the cell where a tile
;; should be placed.
;;
;; NOTE: we don't have to adjust for the inset here, as it is already
;; taken into account by `move-to`
(define/private (location->xy l)
(define-values (cell-width cell-height) (send theme get-cell-size))
(match-define (location column row) l)
(values
(+ board-x (* cell-width column))
(+ board-y (* cell-height row))))
;; Move the TILE to a place on the board according to its location, the
;; tile must already be inserted into the pasteboard. If location is #f
;; it is moved into the next-tile space.
(define/private (place-tile-on-board tile)
(define-values (cell-width cell-height) (send theme get-cell-size))
(if (send tile get-location)
(let-values ([(x y) (location->xy (send tile get-location))])
(send this move-to tile x y))
(send this move-to tile
(+ next-tile-x (/ (- next-tile-width cell-width) 2))
(+ next-tile-y (/ (- next-tile-height cell-height) 2)))))
;; Return the tile which is present at LOCATION (a location structure).
;; We iterate over all tiles which are inserted into the pasteboard and
;; search for the one which has the location we are looking for.
;;
;; This method illustrates how we can iterate over the tiles which are
;; inserted into the pasteboard.
(define/private (tile-at-location location)
(let loop ([tile (send this find-first-snip)])
(if tile
(if (equal? location (send tile get-location))
tile
(loop (send tile next)))
#f)))
;; Return #t if TILE can be placed at LOCATION. It can be placed there if
;; the location is free and all the neighbors are "compatible" according
;; to `can-be-neighbors?`.
(define/private (valid-drop-location? tile location)
(and (not (tile-at-location location)) ; needs to be a free slot
(let ([neighbours (for*/list ([n (neighbour-locations location)]
[t (in-value (tile-at-location n))]
#:when (and t (not (equal? t tile))))
t)])
(and (not (null? neighbours))
(for/and ([n neighbours])
(can-be-neighbors? (send tile get-key) (send n get-key)))
;; return the score of this location if it is valid
(expt 2 (sub1 (length neighbours)))))))
;; Refresh all the snips that are inserted into the pasteboard. This is
;; called when the canvas size has changed and the snips need to be
;; realigned. Note the use of `{begin,end}-edit-sequence` to avoid
;; multiple refreshes triggered by the move operations.
(define/private (refresh-all-snips)
(send this begin-edit-sequence)
(let loop ([snip (send this find-first-snip)])
(when snip
(define admin (send snip get-admin))
(send admin resized snip #t)
(place-tile-on-board snip)
(loop (send snip next))))
(send this end-edit-sequence))
;; This method is called by the system when the size of the canvas has
;; changed. We use this opportunity to recalculate the board and next
;; tile locations as well as the cell size and refresh all the snips which
;; are inserted into the pasteboard.
(define/augride (on-display-size)
(define admin (send this get-admin))
(define canvas (send this get-canvas))
(define internal-border 2)
(when (and admin canvas)
(let ((x (box 0))
(y (box 0))
(w (box 0))
(h (box 0)))
(send admin get-view x y w h #f)
;; NOTE: the x, y coordinates of the board need to be adjusted for
;; the editor canvas inset, but the width and the height do not.
(set! board-x (+ internal-border (unbox x)))
(set! board-y (+ internal-border (unbox y)))
(set! board-width (- (* 0.8 (unbox w)) internal-border internal-border))
(set! board-height (- (* 1.0 (unbox h)) internal-border internal-border))
(define-values (cell-width cell-height)
(values (/ board-width board-columns) (/ board-height board-rows)))
(set! next-tile-width (* 1.7 cell-width))
(set! next-tile-height (* 1.7 cell-height))
(set! next-tile-x (+ board-x board-width
(/ (- (unbox w) board-x board-width internal-border next-tile-width) 2)))
(set! next-tile-y (+ (unbox y) internal-border))
(send theme set-cell-size cell-width cell-height)
(refresh-all-snips))))
;; This is a helper method to draw a square on the board at location LOC.
;; It is used both to draw the shaded cells, as well as to highlight a
;; location or to display the score of each placement.
(define/private (shade-cell dc loc
#:text (text #f)
#:font (font info-font)
#:pen (pen transparent-pen)
#:brush (brush shade-brush))
(match-define (location column row) loc)
;; NOTE: we assume that the DC origin is set such that it accounts for
;; the horizontal and vertical inset of the editor-canvas%
(send dc set-brush brush)
(send dc set-pen pen)
(define-values (cell-width cell-height) (send theme get-cell-size))
(define x (+ board-x (* column cell-width)))
(define y (+ board-y (* row cell-height)))
(send dc draw-rectangle x y cell-width cell-height)
(when text
(define-values (width height baseline extra-space)
(send dc get-text-extent text font #t))
(send dc set-font font)
(send dc set-text-foreground "Dark Slate Gray")
(let ((ox (/ (- cell-width width) 2))
(oy (/ (- cell-height height) 2)))
(send dc draw-text text (+ x ox) (+ y oy)))))
;; This is a helper method to draw the board in the background. We draw
;; the shaded cells first by calling `shade-cell` on all
;; `shaded-locations`, than draw horizontal and vertical lines to build
;; the rest of the squares.
(define/private (draw-ishido-board dc)
(define-values (old-origin-x old-origin-y) (send dc get-origin))
(send dc set-origin (+ old-origin-x board-x) (+ old-origin-y board-y))
(define-values (cell-width cell-height) (send theme get-cell-size))
(for ([location (in-list shaded-locations)])
(shade-cell dc location))
(send dc set-brush transparent-brush)
(send dc set-pen pen)
(for ([row (in-range (add1 board-rows))])
(send dc draw-line 0 (* row cell-height) board-width (* row cell-height)))
(for ([column (in-range (add1 board-columns))])
(send dc draw-line (* column cell-width) 0 (* column cell-width) board-height))
(send dc set-origin old-origin-x old-origin-y)
(send dc set-brush shade-brush)
(send dc draw-rectangle next-tile-x next-tile-y next-tile-width next-tile-height))
;; If there is a highlight-location, use shade-cell to display it
(define (maybe-highlight-location dc)
(when highlight-location
(shade-cell dc highlight-location #:pen highlight-pen #:brush transparent-brush)))
;; Use shade-cell to mark all the valid drop locations with their score
(define (show-valid-drop-locations dc)
(for ([drop-location (in-list valid-drop-locations)])
(match-define (list locaction score) drop-location)
(shade-cell dc locaction #:pen valid-location-pen #:brush transparent-brush
#:text (~a score))))
;; Display the current score and remaining number of tiles.
(define (show-score dc)
(send dc set-font info-font)
(send dc set-text-foreground "Dark Slate Gray")
(send dc draw-text (format "Score: ~a" score)
next-tile-x (+ next-tile-y next-tile-height 20))
(send dc draw-text (format "Remaining: ~a" (length pouch))
next-tile-x (+ next-tile-y next-tile-height 50)))
;; This method is called when the canvas itself (not the snips) need to be
;; drawn. It is called twice during each draw process: once before the
;; snips are drawn and once after they are drawn.
;;
;; Before the snips are drawn, we draw the board and the next tile place
;; plus the score and remaining tiles, after the snips are drawn, we draw
;; the "game over" message, if the end of the game was reached.
(define/override (on-paint before? dc . other)
(define canvas (send this get-canvas))
(when canvas
;; For non high-resolution display, a smoothed draw looks nicer...
;; (send dc set-smoothing 'smoothed)
(when before?
(send dc clear)
(define vinset (send canvas vertical-inset))
(define hinset (send canvas horizontal-inset))
(define-values (old-origin-x old-origin-y) (send dc get-origin))
(send dc set-origin hinset vinset)
(draw-ishido-board dc)
(maybe-highlight-location dc)
(show-valid-drop-locations dc)
(show-score dc)
(send dc set-origin old-origin-x old-origin-y))
(unless before?
;; This draw call is done after the snips have been drawn and allows
;; us to draw something on top of the entire board.
(when game-over?
(if winning?
(draw-centered-message dc "Game Over. You Win!")
(draw-centered-message dc "Game Over"))))))
;; These two values define the position on the chess piece where the mouse
;; picked it up for dragging. It is used to determine on what square the
;; piece would be dropped and it is used by `on-move-to` to find the
;; square that needs to be highlighted -- these values are not used when
;; positioning a dropped piece, as the mouse coordinates are available
;; once again at that point.
(define-values (drag-dx drag-dy) (values 0 0))
;; This method is invoked once only when the user begins to drag a tile
;; and only if `can-interactive-move?` allowed the drag to happen. We use
;; this opportunity to record the offsets where the mouse picked up the
;; piece (`drag-dx` and `drag-dy`)
(define/augment (on-interactive-move event)
(define piece (send this find-next-selected-snip #f))
(define-values (x y) (values (box 0) (box 0)))
(send this get-snip-location piece x y #f)
(set! drag-dx (- (send event get-x) (unbox x)))
(set! drag-dy (- (send event get-y) (unbox y))))
;; This method is invoked after a snip is moved, either interactively by
;; dragging it or when `move-to` is called. Note that the pasteboard is
;; locked during this call, and as such we cannot use this method to
;; add/remove or move snips around.
;;
;; We can however use it to determine which would be the "drop" location
;; of a tile and update the highlighted location for it. We don't
;; actually highlight the location here, instead we as the canvas to be
;; refreshed. All drawing is done in the `on-paint` method.
(define/augment (on-move-to snip x y dragging?)
(when dragging?
;; NOTE: we need to adjust by `drag-dx` and `drag-dy`, since we want
;; to highlight the square under the mouse pointer, not the square
;; where the top-left corner of the snip is.
(let ((location (xy->location (+ x drag-dx) (+ y drag-dy))))
(unless (equal? highlight-location location)
(set! highlight-location location)
;; Since the visual appearance has changed, tell the canvas that
;; it needs to be refreshed.
(send (send this get-canvas) refresh)))))
;; Determine the list of valid locations where TILE can be placed on the
;; board. We simply iterate over all the board position and use
;; `valid-drop-location?` to determine if a location is suitable.
(define/private (get-valid-locations tile)
(for*/list ([row (in-range board-rows)]
[column (in-range board-columns)]
[location (in-value (location column row))]
[score (in-value (valid-drop-location? tile location))]
#:when score)
(list location score)))
;; This method is invoked to place a new tile in the "next tile" location,
;; from where the user can drag it onto the board. If the pouch is empty,
;; we set the game over flag, if it is not, we insert the next tile into
;; the pasteboard (which will make it visible) and update the valid drop
;; locations for this tile -- if there are none, also set the game over
;; flag.
(define/private (on-new-tile)
;; Since we assigned a location to the current piece, grab a new one
;; from the pouch.
(if (null? pouch)
(begin
(set! game-over? #t)
(set! winning? #t))
(let ((next-tile (car pouch)))
(set! valid-drop-locations (get-valid-locations next-tile))
(send this insert next-tile)
(set! pouch (cdr pouch))
(when (null? valid-drop-locations)
(set! game-over? #t)
(set! winning? #f)))))
;; This method is invoked after the user finished dragging a tile on the
;; board. Note that we receive the mouse event which ended the move, and
;; we need to obtain the tile using `find-next-selected-snip`. We
;; determine if the drop location for the tile is valid -- snap the tile
;; to that position, update the score and grab a new tile by calling
;; `on-new-tile`.
;;
;; If the selected location is not valid, the tile is moved back to the
;; next tile location.
(define/augment (after-interactive-move event)
(define piece (send this find-next-selected-snip #f))
(unless (send piece get-location)
;; Set the new location, only if the piece does not already have one.
(define drop-location (xy->location (send event get-x) (send event get-y)))
(when drop-location
(define location-score (valid-drop-location? piece drop-location))
(when location-score
(send piece set-location drop-location)
(set! score (+ score location-score))
(on-new-tile))))
;; If we don't update the location, the piece will be moved back
(place-tile-on-board piece)
(set! highlight-location #f)
(send (send this get-canvas) refresh))
;; Called when a new snip (tile%) is inserted. We check if the snip is a
;; `tile%` object than call `place-tile-on-board` which will move the tile
;; to its correct position based in its location.
(define/augment (after-insert tile . rest)
(unless (is-a? tile tile%)
(error "after-insert: bad snip kind"))
(place-tile-on-board tile))
;; Called just after SNIP was selected (ON? is #t) or unselected. We
;; ensure that the snip is on the top in the Z-order, so it is drawn on
;; top of others when it is dragged on the board.
;;
;; By default, the pasteboard allows multiple snips to be selected --
;; since we only want one snip selected at the time, we manually de-select
;; any other selected snips when this method is called.
(define/augment (after-select snip on?)
(when on?
;; the SNIP was just selected, we have several things to do:
;; (1) Put this snip in the front of the snip list, so it will be
;; dragged in front of all other snips (we don't really care of the
;; actual order of snips in the pasteboard, so we freely reorder them
;; as needed.
(send this set-before snip #f)
;; (2) Find any other selected snips and un-select them, we do this in
;; two stages, as we cannot un-select snips while traversing the list,
;; as this would break the traversal. First, we collect the other
;; selected snips in `other-selected-snips`...
(define other-selected-snips
(let loop ((other (send this find-next-selected-snip #f))
(result '()))
(if other
(let ((next (send this find-next-selected-snip other)))
(if (eq? snip other)
(loop next result)
(loop next (cons other result))))
result)))
;; ... than we actually un-select them
(for ([snip other-selected-snips])
(send this remove-selected snip))
;; Since we changed several things, let the canvas know that it needs
;; be re-drawn
(send (send this get-canvas) refresh)))
;; This method is used to start a new game
(define/public (new-game)
;; Clear any tiles that are inserted into the pasteboard (in case we
;; start a new game after a game was already played). This is tricker
;; than it sounds. The simplest way to clear the tiles is to use
;; `select-all` and than `clear`, but this will not work, as
;; `after-select` will be called for each snip which will unselect them
;; causing an infinite loop. Instead we need to collect the snips and
;; call remove on each one.
(define all-snips
(let loop ([result '()]
[snip (send this find-first-snip)])
(if snip
(loop (cons snip result) (send snip next))
result)))
(for ([snip all-snips])
(send this remove snip))
(define the-pouch
(let loop ([pouch (make-pouch theme)]
[locations initial-locations])
(if (null? locations)
pouch
(let ([tile (car pouch)])
(send tile set-location (car locations))
(send board insert tile)
(loop (cdr pouch) (cdr locations))))))
(set! pouch the-pouch)
(set! game-over? #f)
(set! winning? #f)
(set! score 0)
;; Next tile to be played has no location and will end up in the "next
;; tile" box.
(on-new-tile)
(send (send this get-canvas) refresh))
;; Install a new keymap in the pasteboard, which will shadow the various
;; key movements, so the user cannot move or delete snips with the
;; keyboard. By default, the user can select a snip and move it with the
;; keyboard or delete it by pressing "del" or "backspace", which is
;; undesirable in a game.
(define (on-disabled-key-event data event) (void))
(define k (new keymap%))
(send k add-function "ignore" on-disabled-key-event)
(send k map-function "up" "ignore")
(send k map-function "down" "ignore")
(send k map-function "left" "ignore")
(send k map-function "right" "ignore")
(send k map-function "del" "ignore")
(send k map-function "backspace" "ignore")
(send this set-keymap k)
;; By default, snips can be resized interactively, by dragging their
;; corner. We deny that by overriding the `can-resize?` method which is
;; called before a resize is attempted. We can allow or deny resizing
;; based on any criteria, but in our case, no snip is resizable, so we
;; return #f.
(define/augride (can-resize? snip w h) #f)
;; By default, snips can be selected by dragging an area in the
;; pasteboard. This is undesirable in the game, so we disable it.
(send this set-area-selectable #f)
;; By default, the pasteboard will draw 8 small squares around a selected
;; snip, disable that feature.
(send this set-selection-visible #f) ; no default visible selection
))
;;......................................................... main program ....
;; Based of Tol's Bright Qualitative Color Scheme
(define bq-colors
(vector
(make-color 68 119 170) (make-color 102 204 238) (make-color 34 136 51)
(make-color 204 187 68) (make-color 238 102 119) (make-color 170 51 119)))
;; http://unicode.org/emoji/charts/full-emoji-list.html
(define bird-glyphs "\U1F99A\U1F99C\U1F9A9\U1F989\U1F986\U1F985")
;; Alternate tile set
(define fruit-glyphs "\U1F347\U1F349\U1F34B\U1F34E\U1F352\U1F353")
;; Construct the theme and the board
(define theme (new theme% [colors bq-colors] [glyphs bird-glyphs]))
(define board (new board% [theme theme]))
;; This is the toplevel frame for the game
(define toplevel
(new frame%
[label "Ishido"]
[width 850]
[height 600]))
;; This is the editor canvas which will "host" the game board -- note that the
;; "editor" init field is set to the board.
(define canvas
(new editor-canvas%
[parent toplevel]
[style '(no-hscroll no-vscroll)]
[horizontal-inset 30]
[vertical-inset 30]
[editor board]))
;; Start a new game and show the game window.
(send board new-game)
(send toplevel show #t)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment