Ishido Game Impementation

ishido.rkt

#lang racket
;; Ishido Game Implementation

;; Copyright (c) 2020 Alex Harsányi ([email protected])

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