https://alex-hhh.github.io/2018/10/chess-game-using-racket-s-pasteboard-part-3.html

chess-board8.rkt

#lang racket/gui

;; Copyright (c) 2018 Alex Harsanyi

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


;; This is a chess board program implemented in Racket, it is the final
;; program described in the following series of blog posts:
;;
;; https://alex-hhh.github.io/2018/10/chess-game-using-racket-s-pasteboard.html
;;
;; https://alex-hhh.github.io/2018/10/chess-game-using-racket-s-pasteboard-part-2.html
;;
;; https://alex-hhh.github.io/2018/10/chess-game-using-racket-s-pasteboard-part-3.html

(require embedded-gui)   ; needed for `snip-width` and `snip-height` functions

;; A snip class is needed for every "kind" of snip that is managed in the
;; pasteboard.  They are used only for serialization, but we need to specify
;; one even if we don't use
(define chess-piece-snip-class
  (make-object
   (class snip-class%
     (super-new)
     (send this set-classname "chess-piece-snip"))))

;; The chess-piece-snip-class instance needs to be registered with the Racket
;; GUI system...
(send (get-the-snip-class-list) add chess-piece-snip-class)

;; A snip% class to represent our chess pieces.  There is a single class for
;; all pieces, and their differences (name, glyph, moves, etc) are fields
;; passed in to the constructor...
(define chess-piece%
  (class snip%
    (init-field
     name   ; mnemonic name for the piece, e.g "K", "n", etc
     glyph  ; Unicode character for the chess piece (this is what it is drawn)
     font   ; font used to draw the glyph
     size   ; size of the chess piece (it is a square)
     moves  ; function to return the valid moves for this piece
     [location #f])          ; location of this piece on the board (e.g. "d3")
    (super-new)

    ;; Register this snip instance to belong to the `chess-piece-snip-class`,
    ;; without this, the `pasteboard%` will refuse to use our snips...
    (send this set-snipclass chess-piece-snip-class)

    (define selected? #f) ; when #t, this piece is selected on the chess board

    ;; Tells this chess piece that it is now selected
    (define/public (set-selected on?)
      (set! selected? on?)
      ;; Since the selected pieces are drawn differently from non-selected
      ;; ones, we need to inform our administrator that the chess piece needs
      ;; to update its visual representation on the board...  The admin itself
      ;; will schedule a call to `draw` sometimes later...
      (let ((admin (send this get-admin)))
        (when admin
          (send admin needs-update this 0 0 size size))))

    ;; Set/Get the location of this piece on the chess board.  The location is
    ;; a string in chess notation (e.g. "d3")
    (define/public (set-location l) (set! location l))
    (define/public (get-location) location)

    ;; Return the color of this piece: white or black.  The color is
    ;; determined from the name of the piece: uppercase names are white,
    ;; lowercase are black (this conforms to the chess notation for pieces,
    ;; e.g. "K" is the white king, "k" is the black king.
    (define/public (color)
      (if (equal? (string-upcase name) name) 'white 'black))

    ;; Return a list of locations where this piece can move to based on its
    ;; current location and the location of other pieces on the board.  This
    ;; method makes use of the `moves` function passed in at creation time.
    (define/public (valid-moves)
      (let ((admin (send this get-admin)))
        (if (and admin location)        ; can be #f is the snip is not owned
            (let ((board (send admin get-editor)))
              (moves board location))
            ;; Return an empty list if this piece is not on a board
            '())))

    ;; Return the size of this snip on the board.  Note that the return values
    ;; here need to be consistent and not change from one invocation to the
    ;; next.  If the snip wishes to changes its size it needs to inform its
    ;; administrator using the `resized` method fist.
    (define/override (get-extent dc x y width height descent space lspace rspace)
      (when width (set-box! width size))
      (when height (set-box! height size))
      (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 chess piece on the board at X, Y location.  The device context
    ;; DC for the board is also passed in...
    (define/override (draw dc x y . other)
      (send dc set-font font)
      ;; If the snip is selected draw it in red, otherwise use black -- note
      ;; that white pieces differ in shape from black ones, so they are still
      ;; drawn in black.
      (if selected?
          (send dc set-text-foreground "red")
          (send dc set-text-foreground "black"))
      ;; Find the dimensions of the glyph so that it is drawn in the middle of
      ;; the chess piece...
      (define-values (glyph-width glyph-height baseline extra-space)
        (send dc get-text-extent glyph font #t))
      (let ((ox (/ (- size glyph-width) 2))
            (oy (/ (- size glyph-height (- baseline) (- extra-space) 2))))
        (send dc draw-text glyph (+ x ox) (+ y oy))))

    ))

(define (valid-rank? rank) (and (>= rank 0) (< rank 8)))
(define (valid-file? file) (and (>= file 0) (< file 8)))

;; Return a list of valid moves for the pawn chess piece.  COLOR BOARD and
;; LOCATION are taken into account to determine the moves.  Note that the list
;; of moves will also include the places where the pawn can capture an
;; opponent piece, but will not include the places where the same color pieces
;; are located.
(define ((pawn-moves color) board location)
  (define direction (if (eq? color 'white) -1 1))
  (define-values (rank file) (location->rank-file location))
  (define moves '())
  (when (valid-rank? (+ rank direction))
    ;; can move forward if that square is not occupied
    (let ((candidate (rank-file->location (+ rank direction) file)))
      (unless (piece-at-location board candidate)
        (set! moves (cons candidate moves))
        (when (valid-rank? (+ rank direction direction))
          ;; can move two squares forward if the pawn is in its original location
          (when (or (and (eq? color 'white) (equal? rank 6))
                    (and (eq? color 'black) (equal? rank 1)))
            (let ((candidate (rank-file->location (+ rank direction direction) file)))
              (unless (piece-at-location board candidate)
                (set! moves (cons candidate moves))))))))
    ;; can move forward left if that square is occupied
    (when (valid-file? (sub1 file))
      (let ((candidate (rank-file->location (+ rank direction) (sub1 file))))
        (let ((piece (piece-at-location board candidate)))
          (when (and piece (not (eq? color (send piece color))))
            (set! moves (cons candidate moves))))))
    ;; can move forward right if that square is occupied
    (when (valid-file? (add1 file))
      (let ((candidate (rank-file->location (+ rank direction) (add1 file))))
        (let ((piece (piece-at-location board candidate)))
          (when (and piece (not (eq? color (send piece color))))
            (set! moves (cons candidate moves)))))))

  moves)

;; Determine the list of valid moves by applying an offset to the current
;; LOCATION.  The kind and knight can move to specific locations, and these
;; locations are passed in as the OFFSETS.  This function returns the list of
;; such locations which are either empty or contain an opponent piece.
(define (valid-moves-by-offset color board location offsets)
  (define-values (rank file) (location->rank-file location))
  (for/fold ([moves '()])
            ([offset (in-list offsets)])
    (match-define (list roffset foffset) offset)
    (define-values (nrank nfile) (values (+ rank roffset) (+ file foffset)))
    (if (and (valid-rank? nrank) (valid-file? nfile))
        (let ((candidate (rank-file->location nrank nfile)))
          (let ((piece (piece-at-location board candidate)))
            (if (or (not piece) (not (eq? (send piece color) color)))
                (cons candidate moves)
                moves)))
        moves)))

;; Determine the list of moves by moving in a certain direction.  Queens,
;; Bishop and Rook pieces move in specific directions.  A list of adjacent
;; squares is returned until an occupied location is found -- the list will
;; include the occupied location if it is used up by an opponent piece.
(define (valid-moves-by-direction color board location rank-direction file-direction)
  (define-values (rank file) (location->rank-file location))
  (define moves '())
  (define (check rank file)
    (let ((candidate (rank-file->location rank file)))
      (let ((target-piece (piece-at-location board candidate)))
        (when (or (not target-piece) (not (eq? (send target-piece color) color)))
          (set! moves (cons candidate moves)))
        (if target-piece #f #t))))
  (let loop ((nrank (+ rank rank-direction))
             (nfile (+ file file-direction)))
    (when (and (valid-rank? nrank) (valid-file? nfile) (check nrank nfile))
      (loop (+ nrank rank-direction) (+ nfile file-direction))))
  moves)

;; Returns the valid list of moves for a knight piece based on color location
;; and the location of the rest of the pieces on the board.
(define ((knight-moves color) board location)
  (valid-moves-by-offset
   color board location
   '((-1 -2) (-1 2) (1 -2) (1 2) (-2 -1) (-2 1) (2 -1) (2 1))))

;; Returns the valid list of moves for a king piece based on color location
;; and the location of the rest of the pieces on the board.
(define ((king-moves color) board location)
  (valid-moves-by-offset
   color board location
   '((-1 -1) (-1 0) (-1 1) (0 -1) (0 1) (1 -1) (1 0) (1 1))))

;; Returns the valid list of moves for a rook piece based on color location
;; and the location of the rest of the pieces on the board.
(define ((rook-moves color) board location)
  (append
   (valid-moves-by-direction color board location 1 0)
   (valid-moves-by-direction color board location -1 0)
   (valid-moves-by-direction color board location 0 1)
   (valid-moves-by-direction color board location 0 -1)))

;; Returns the valid list of moves for a bishop piece based on color location
;; and the location of the rest of the pieces on the board.
(define ((bishop-moves color) board location)
  (append
   (valid-moves-by-direction color board location 1 1)
   (valid-moves-by-direction color board location -1 1)
   (valid-moves-by-direction color board location 1 -1)
   (valid-moves-by-direction color board location -1 -1)))

;; Returns the valid list of moves for a queen piece based on color location
;; and the location of the rest of the pieces on the board.
(define ((queen-moves color) board location)
  (append
   (valid-moves-by-direction color board location 1 0)
   (valid-moves-by-direction color board location -1 0)
   (valid-moves-by-direction color board location 0 1)
   (valid-moves-by-direction color board location 0 -1)
   (valid-moves-by-direction color board location 1 1)
   (valid-moves-by-direction color board location -1 1)
   (valid-moves-by-direction color board location 1 -1)
   (valid-moves-by-direction color board location -1 -1)))

;; Hold piece specific information about every type of chess piece that we can
;; have.  This maps a chess piece name to the glyph used for rendering and the
;; moves function which determines the valid moves for the piece --
;; `make-chess-piece` uses this table to create chess pieces.
(define chess-piece-data
  (hash
   "K" (cons #\u2654 (king-moves 'white))
   "Q" (cons #\u2655 (queen-moves 'white))
   "R" (cons #\u2656 (rook-moves 'white))
   "B" (cons #\u2657 (bishop-moves 'white))
   "N" (cons #\u2658 (knight-moves 'white))
   "P" (cons #\u2659 (pawn-moves 'white))
   "k" (cons #\u265A (king-moves 'black))
   "q" (cons #\u265B (queen-moves 'black))
   "r" (cons #\u265C (rook-moves 'black))
   "b" (cons #\u265D (bishop-moves 'black))
   "n" (cons #\u265E (knight-moves 'black))
   "p" (cons #\u265F (pawn-moves 'black))))

;; Create a new chess piece snip based on ID and LOCATION.  This function
;; determines the rest of the parameters required by the `chess-piece%` class
;; and instantiates it.
(define (make-chess-piece id [location #f])
  (match-define (cons glyph moves) (hash-ref chess-piece-data id))
  (define font (send the-font-list find-or-create-font 20 'default 'normal 'normal))
  (new chess-piece%
       [name id]
       [glyph (string glyph)]
       [font font]
       [size 35]
       [location location]
       [moves moves]))

;; A pasteboard to represent a chess game board.  It allows placing pieces at
;; the correct locations and moving them according to chess game rules.
(define chess-board%
  (class pasteboard%
    (super-new)

    ;; Disable area selection for this snip -- in the chess game we can select
    ;; a piece by clicking on it...
    (send this set-area-selectable #f)

    ;; Disable the display of markers when a snip is selected -- chess piece
    ;; snips handle the "selected" visual cue themselves.
    (send this set-selection-visible #f)

    ;; Handler for ignored key map events, this could be an empty procedure,
    ;; but for illustration purposes it will display the disabled key name
    ;; using `set-message`
    (define (on-disabled-key-event data event)
      (if (is-a? event key-event%)
          (let* ((code (send event get-key-code))
                 (key-name (cond ((symbol? code) (symbol->string code))
                                 ((equal? code #\backspace) "backspace")
                                 ((equal? code #\rubout) "delete")
                                 ((equal? code #\space) "space")
                                 ((equal? code #\return) "return")
                                 (#t (string code)))))
            (set-message (format "~a key is disabled" key-name)))
            (set-message "event is discarded")))

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

    ;; Message to be displayed to the user, or #f if no message is to be
    ;; displayed.
    (define message #f)
    ;; A location name that should be highlighted on the board, or #f if no
    ;; location is to be highlighted
    (define highlight-location #f)
    ;; List of locations that are considered a valid move, they will be
    ;; highlighted in a special way
    (define valid-move-locations '())
    ;; List of locations that are controlled by the opponent, they will be
    ;; highlighted in a special way
    (define opponent-move-locations '())

    ;; The `on-paint` method is responsible for drawing any non-interactive
    ;; parts of the chess board game: the chess board itself, any highlighted
    ;; squares plus a message displayed to the user (if any).  This method is
    ;; invoked twice: first, before the chess pieces are drawn and once after.
    (define/override (on-paint before? dc . other)
      (if before?
          ;; If we are invoked before the snips are drawn, we draw the chess
          ;; board and highlighted squares
          (begin
            (draw-chess-board dc)
            (for ((location (in-list valid-move-locations)))
              (highlight-square dc location #f "seagreen"))
            (for ((location (in-list opponent-move-locations)))
              (highlight-square dc location "firebrick" #f))
            (when highlight-location
              (highlight-square dc highlight-location #f "indianred")))
          ;; After the snips are drawn, we draw the message, if any
          (when message
            (display-message dc message))))

    ;; A message timer is used to clear the message after a timeout period,
    ;; see `set-message`
    (define message-timer
      (new timer%
           [notify-callback
            (lambda ()
              (set! message #f)
              (send (send this get-canvas) refresh))]))

    ;; This method is invoked when the size of the canvas changes.  We use
    ;; this opportunity to place the snips at their new coordinates depending
    ;; on their locations (since the size of the squares has changed).  Note
    ;; that we use `begin-edit-sequence`/`end-edit-sequence` to prevent
    ;; unneeded refreshes while we reposition several pieces.
    (define/augment (on-display-size)
      (send this begin-edit-sequence)
      (let loop ([snip (send this find-first-snip)])
        (when snip
          ;; Reposition the piece, since the location is stored as text
          ;; (e.g. d3) its new coordinates will be recomputed to the correct
          ;; place
          (position-piece this snip)
          (loop (send snip next))))
      (send this end-edit-sequence))

    ;; Set a message to be displayed to the user.  The message will be
    ;; displayed for a period of time, than it will disappear automatically
    (define (set-message m)
      (set! message m)
      ;; Set a timer to clear the message after 2 seconds
      (send message-timer start 2000)
      ;; Inform the canvas that it needs to be re-drawn.
      (send (send this get-canvas) refresh))

    ;; This method is invoked before a snip is inserted into the
    ;; pasteboard. If this method returns #f, the insert is aborted.
    (define/augment (can-insert? snip . rest)
      ;; We can insert a snip if...
      (and
       ;; ... it is an instance of chess-piece%
       (is-a? snip chess-piece%)
       ;; ... has a location set....
       (send snip get-location)
       ;; ... the location is not occupied by another piece
       (not (piece-at-location this (send snip get-location)))))

    ;; This method is invoked after a snip is inserted into the pasteboard.
    ;; We use this opportunity to position the snip at the right coordinates,
    ;; corresponding to its location.
    (define/augment (after-insert chess-piece . rest)
      (position-piece this chess-piece))

    ;; This variable keeps track of which color piece can move next.  It can
    ;; be either 'white or 'black
    (define turn 'white)

    ;; This method is invoked each time a snip is selected or un-selected in
    ;; the pasteboard and it allows us to perform several operations when this
    ;; happens (see below)
    (define/augment (after-select snip on?)
      ;; Tell the snip itself that it was selected/unselected
      (send snip set-selected 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))

        (define color (send snip color))

        ;; (3) If the selected piece has the wrong color, let the user know
        ;; (but we still allow selection)
        (unless (eq? turn color)
          (set-message (format "It's ~a turn to move"
                               (if (eq? turn 'white) "white's" "black's"))))
        
        ;; (4) Set the `valid-move-locations` and `opponent-move-locations`
        ;; for the selected snip
        (set! valid-move-locations (send snip valid-moves))
        (set! opponent-move-locations (collect-opponent-moves this color)))

      (unless on?
        ;; the SNIP was unselected so we make the move location lists empty,
        ;; and nothing will be highlighted.
        (set! opponent-move-locations '())
        (set! valid-move-locations '()))

      ;; Since we changed several things, let the canvas know that it needs to
      ;; be re-drawn
      (send (send this get-canvas) refresh))

    ;; This method is invoked when the user attempts to drag a chess piece on
    ;; the board.  If it returns #f, the drag is not permitted.  We disallow
    ;; dragging pieces of the opponents color and set a message to remind the
    ;; user whose turn it is to move.
    (define/augment (can-interactive-move? event)
      (define piece (send this find-next-selected-snip #f))
      ;; The user tried to move a piece of the opposite color, remind them
      ;; again.
      (unless (eq? turn (send piece color))
        (set-message (format "It's ~a turn to move"
                      (if (eq? turn 'white) "white's" "black's"))))
      (eq? turn (send piece color)))

    ;; 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 chess
    ;; piece 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 repeatedly when a piece is moved (whether by
    ;; dragging it or by a call to `move-to`).  If the move is related to a
    ;; drag event (dragging? is #t), we find what square the piece is hovering
    ;; over and set that as the highlighted square.
    (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 this (+ 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)))))

    ;; This method is invoked when the user finished dragging a chess piece on
    ;; the board.  We find the location where the piece was dropped, check if
    ;; it is a valid move and update the board accordingly.  If this is not a
    ;; valid move, the piece is moved back to its original location.
    (define/augment (after-interactive-move event)
      (define piece (send this find-next-selected-snip #f))
      (define location (xy->location this (send event get-x) (send event get-y)))
      (define valid-moves (send piece valid-moves))
      (when (member location valid-moves)
        ;; This is a valid move, remove any target piece and update the piece
        ;; location, note that the target piece, if any, *must* be of the
        ;; opponent color, otherwise `valid-moves` would not have included
        ;; this location in the returned list.
        (let ((target-piece (piece-at-location this location)))
          (when (and target-piece (not (eq? piece target-piece)))
            (send target-piece set-location #f)
            (send this remove target-piece)))
        ;; Now that this piece moved, it is the opponents turn to move
        (set! turn (if (eq? turn 'white) 'black 'white))
        (send piece set-location location))

      ;; This is the place where we move the piece -- if its location changed
      ;; above, the piece will snap to the target square, if it did not
      ;; change, the piece will be moved back to its original location.
      (position-piece this piece)
      ;; Disable highlighting of the drop location, as the piece was now
      ;; dropped back onto the board.
      (set! highlight-location #f)
      ;; Note: piece is still selected, but the valid moves are relative to
      ;; the new position, so we update them.
      (set! valid-move-locations (send piece valid-moves))
      ;; Since the visual appearance has changed, tell the canvas that it
      ;; needs to be refreshed.
      (send (send this get-canvas) refresh))

    ))

;; Return a list of the locations where any piece of COLOR can move to -- this
;; is effectively the list of squares controlled by the pieces of COLOR.
(define (collect-opponent-moves board color)
  (define moves '())
  (let loop ((snip (send board find-first-snip)))
    (when snip
      (unless (eq? (send snip color) color)
        (set! moves (append moves (send snip valid-moves))))
      (loop (send snip next))))
  (remove-duplicates moves))

;; Position a PIECE onto the BOARD according to its location.  This function
;; determines the coordinates of the square where this piece is located,
;; taking into account the size of the board, and moves the piece so it is
;; centered on that square.
(define (position-piece board piece)
  (define-values (canvas-width canvas-height)
    (let ((c (send board get-canvas)))
      (send c get-size)))
  (define-values (square-width square-height)
    (values (/ canvas-width 8) (/ canvas-height 8)))
  (define-values (rank file)
    (location->rank-file (send piece get-location)))
  (define-values (square-x square-y)
    (values (* file square-width) (* rank square-height)))
  (define piece-width (snip-width piece))
  (define piece-height (snip-height piece))
  (send board move-to piece
        (+ square-x (/ (- square-width piece-width) 2))
        (+ square-y (/ (- square-height piece-height) 2))))

;; Convert a location, which is a string, such as "d3" into a rank and file
;; position, which are square coordinates on the board.
(define (location->rank-file location)
  (unless (and (string? location) (= (string-length location) 2))
    (raise-argument-error 'location "valid chess position a1 .. h8" location))
  (define file
    (index-of '(#\a #\b #\c #\d #\e #\f #\g #\h) (string-ref location 0)))
  (define rank
    (index-of '(#\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1) (string-ref location 1)))
  (unless (and rank file)
    (raise-argument-error 'location "valid chess position a1 .. h8" location))
  (values rank file))

;; Convert a RANK and FILE, which are coordinates on the board into a chess
;; location, which is a string, such as "d3"
(define (rank-file->location rank file)
  (unless (<= 0 rank 7)
    (raise-argument-error 'rank "integer between 0 and 7" rank))
  (unless (<= 0 file 7)
    (raise-argument-error 'rank "integer between 0 and 7" file))
  (string
   (list-ref '(#\a #\b #\c #\d #\e #\f #\g #\h) file)
   (list-ref '(#\8 #\7 #\6 #\5 #\4 #\3 #\2 #\1) rank)))

;; Determine the location of the coordinate point at X, Y on the board.
(define (xy->location board x y)
  (define-values (canvas-width canvas-height)
    (let ((c (send board get-canvas)))
      (send c get-size)))
  (define-values (square-width square-height)
    (values (/ canvas-width 8) (/ canvas-height 8)))
  (define-values (rank file)
    (values (exact-truncate (/ y square-height)) (exact-truncate (/ x square-width))))
  (rank-file->location rank file))

;; Return the chess piece at location, a string such as "d3", on the board, or
;; return #f if that location is empty.
(define (piece-at-location board location)
  (let loop ((snip (send board find-first-snip)))
    (if snip
        (if (equal? location (send snip get-location))
            snip
            (loop (send snip next)))
        #f)))

;; Display MESSAGE centered onto the device context DC -- this is used by the
;; pasteboard on-paint method to display messages -- DC is the device context
;; for the canvas itself.
(define (display-message dc message)
  (define font (send the-font-list find-or-create-font 24 'default 'normal 'normal))
  (define-values [w h _1 _2] (send dc get-text-extent message font #t))
  (define-values (dc-width dc-height) (send dc get-size))
  (define-values (x y) (values (/ (- dc-width w) 2) (/ (- dc-height h) 2)))

  (define brush (send the-brush-list find-or-create-brush "bisque" 'solid))
  (define pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
  (send dc set-brush brush)
  (send dc set-pen pen)
  (send dc draw-rectangle 0 y dc-width h)
  (send dc set-font font)
  (send dc set-text-foreground "firebrick")
  (send dc draw-text message x y))

;; Draw the chess board pattern to cover the entire device context DC.  In
;; addition, this function also draws the letters and numbers corresponding to
;; the rank and file locations on the board.  This is used by the pasteboard
;; on-paint method to display the chess board -- DC is the device context for
;; the canvas itself.
(define (draw-chess-board dc)
  (define brush (send the-brush-list find-or-create-brush "gray" 'solid))
  (define pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
  (define font (send the-font-list find-or-create-font 8 'default 'normal 'normal))
  (define-values (dc-width dc-height) (send dc get-size))
  (define cell-width (/ dc-width 8))
  (define cell-height (/ dc-height 8))
  (define margin 3)

  (send dc clear)
  (send dc set-brush brush)
  (send dc set-pen pen)
  (send dc set-font font)

  (for* ([row (in-range 8)] [col (in-range 8)]
         #:when (or (and (odd? row) (even? col))
                    (and (even? row) (odd? col))))
    (define-values [x y] (values (* col cell-width) (* row cell-height)))
    (send dc draw-rectangle x y cell-width cell-height))

  (for ([(rank index) (in-indexed '("8" "7" "6" "5" "4" "3" "2" "1"))])
    (define-values [_0 h _1 _2] (send dc get-text-extent rank font #t))
    (define y (+ (* index cell-height) (- (/ cell-height 2) (/ h 2))))
    (send dc draw-text rank margin y))

  (for ([(file index) (in-indexed '("a" "b" "c" "d" "e" "f" "g" "h"))])
    (define-values [w h _1 _2] (send dc get-text-extent file font #t))
    (define x (+ (* index cell-width) (- (/ cell-width 2) (/ w 2))))
    (send dc draw-text file x (- dc-height h margin))))

;; Draw a square at LOCATION (a chess board location such as "d3") using
;; COLOR-NAME for the background and BORDER-COLOR-NAME for the border -- any
;; of these can be #f in which case the respective item is not drawn.
(define (highlight-square dc location color-name border-color-name)
  (define-values (rank file) (location->rank-file location))
  ;; Define a brush using a color based from COLOR-NAME but add some
  ;; transparency for it.  If COLOR-NAME is #f, we create a transparent brush,
  ;; which effectively means no-brush
  (define brush
    (if color-name
        (let* ((base (send the-color-database find-color color-name))
               (color (make-object color% (send base red) (send base green) (send base blue) 0.3)))
          (send the-brush-list find-or-create-brush color 'solid))
        (send the-brush-list find-or-create-brush "black" 'transparent)))
  ;; Define a pen based on BORDER-COLOR-NAME, or if BORDER-COLOR-NAME is #f a
  ;; transparent pen, which effectively means no pen.
  (define pen
    (if border-color-name
        (send the-pen-list find-or-create-pen border-color-name 4 'solid)
        (send the-pen-list find-or-create-pen "black" 1 'transparent)))
  (send dc set-pen pen)
  (send dc set-brush brush)
  (define-values (dc-width dc-height) (send dc get-size))
  (define-values (cell-width cell-height) (values (/ dc-width 8) (/ dc-height 8)))
  (send dc draw-rectangle (* file cell-width) (* rank cell-height) cell-width cell-height))

;; Create and place pieces on the BOARD according to the definition in
;; POSITION (which is a string like `initial`)
(define (setup-board board position)
  (send board clear)
  (define piece-count (/ (string-length position) 3))
  (for ([index (in-range piece-count)])
    (define pos (* index 3))
    (define name (substring position pos (add1 pos)))
    (define location (substring position (add1 pos) (+ (add1 pos) 2)))
    (send board insert (make-chess-piece name location))))

;; A test program for our chess-piece% objects:

;; The pasteboard% that will hold and manage the chess pieces
(define board (new chess-board%))

;; Toplevel window for our application
(define toplevel (new frame% [label "Chess Board"] [width (* 50 8)] [height (* 50 8)]))

;; The canvas which will display the pasteboard contents
(define canvas (new editor-canvas%
                    [parent toplevel]
                    [style '(no-hscroll no-vscroll)]
                    [horizontal-inset 0]
                    [vertical-inset 0]
                    [editor board]))

;; Initial board configuration for the start of the chess game.
(define initial
  (string-append
   "Ra1Nb1Bc1Qd1Ke1Bf1Ng1Rh1"
   "Pa2Pb2Pc2Pd2Pe2Pf2Pg2Ph2"
   "pa7pb7pc7pd7pe7pf7pg7ph7"
   "ra8nb8bc8qd8ke8bf8ng8rh8"))

(setup-board board initial)
(send toplevel show #t)        ; this actually displays the chess board window