#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)