Edward DeJong's Chess Challenge in Red

chess.red

Red [
	title: "Edward de Jong's Chess Challenge"
	author: ["Gregg Irwin"]
]

; This may prove useful as more logic is added. Right now it's not a big win.
array: function [
	"Makes and initializes a block of of values (NONE by default)"
	size [integer! block!] "Size or block of sizes for each dimension"
	/initial "Specify an initial value for elements"
		value "For each item: called if a func, deep copied if a series"
][
	if block? size [
		if tail? more-sizes: next size [more-sizes: none]
		size: first size
		if not integer? size [
			; throw error, integer expected
			cause-error 'script 'expect-arg reduce ['array 'size type? get/any 'size]
		]
	]
	result: make block! size
	case [
		block? more-sizes [
			loop size [append/only result array/initial more-sizes :value]
		]
		series? :value [
			loop size [append/only result copy/deep value]
		]
		any-function? :value [
			loop size [append/only result value]
		]
		'else [
			append/dup result value size
		]
	]
	result
]

;-------------------------------------------------------------------------------

; If anyone wants to fork this and add to it, feel free. Not sure how much 
; more time I'll put into it. Mainly, it was a brain relaxer, thinking about
; how I might represent a chess game, which I haven't done before. 
;
; - Board moves should be an executable dialect.
; - Use draw commands to overlay highlighted cells for legal move targets?
; - Set up DRAW blocks for each face, to superimpose glyphs and colors.
; - Ask @VirtualAlan for sound playing code?
; - Design movement dialect for each piece, for use with move algorithm.

board-size: 8x8

; We'll need to use DRAW to overlay the outline, rather than just using the 
; chars as the text on a face. We could do just the text to start, since it
; has nothing to do with the game logic.
;solid-chars: collect [repeat i 6 [keep to char! 9817 + i]]
;outline-chars: collect [repeat i 6 [keep to char! 9811 + i]]
piece-chars: #()
;piece-chars/solid:   #(K: #"♚" Q: #"♛" R: #"♜" B: #"♝" N: #"♞" P: #"♟")
;piece-chars/outline: #(K: #"♔" Q: #"♕" R: #"♖" B: #"♗" N: #"♘" P: #"♙")
piece-chars/solid:   #(K: "♚" Q: "♛" R: "♜" B: "♝" N: "♞" P: "♟")
piece-chars/outline: #(K: "♔" Q: "♕" R: "♖" B: "♗" N: "♘" P: "♙")

;char-colors: #(
;	solid:   #(b: #494040 w: #ebd3bc)
;	outline: #(b: #1c1818 w: #494040)
;)
char-colors: #(
	b: #(solid: #494040 outline: #1c1818)			; black
	w: #(solid: #ebd3bc outline: #494040)			; white
)

draw-piece: function [
	face  [object!]
	piece [lit-path! none! word!] "e.g. 'b/K 'wP"
][
	if piece = 'none [piece: none]
	;color: char-colors/(piece/1)
	;solid-ch: piece-chars/solid/(piece/2)
	;outline-ch: piece-chars/outline/(piece/2)
	
	face/draw/:D_COLOR_SOLID:   to tuple! either piece [char-colors/(piece/1)/solid  ][#FFFFFF]
	face/draw/:D_CHAR_SOLID:    either piece [piece-chars/solid/(piece/2)  ][""]
	face/draw/:D_COLOR_OUTLINE: to tuple! either piece [char-colors/(piece/1)/outline][#000000]
	face/draw/:D_CHAR_OUTLINE:  either piece [piece-chars/outline/(piece/2)][""]

	show face									; auto-sync is off, so we need to show the face
]

;-------------------------------------------------------------------------------

; path! values are piece markers: color/piece-code (P for pawn)
; The idea being that we can map these to the above data structures easily,
; without having to form and split them if they were words. Seems cleaner
; than nested blocks as well. It also, quite nicely, makes the path length
; match the word 'none.
new-board-map: [
	['b/R 'b/N 'b/B 'b/K 'b/Q 'b/B 'b/N 'b/R]
	['b/P 'b/P 'b/P 'b/P 'b/P 'b/P 'b/P 'b/P]
	[none none none none none none none none]
	[none none none none none none none none]
	[none none none none none none none none]
	[none none none none none none none none]
 	['w/P 'w/P 'w/P 'w/P 'w/P 'w/P 'w/P 'w/P]
 	['w/R 'w/N 'w/B 'w/K 'w/Q 'w/B 'w/N 'w/R]
]
cur-board-map: none

; TBD: Square behavior
_on-down:   function [f e][] ;[set-map-val-from-sq f now/time]
_on-up:     function [f e][print [f/extra/name f/extra/piece get-map-val-from-sq f]]

piece-font: make font! [size: 36]

; Draw block indexes, we'll use to poke values for each piece
D_COLOR_SOLID:   4
D_CHAR_SOLID:    7
D_COLOR_OUTLINE: 9
D_CHAR_OUTLINE: 12

board-spec: copy [
	backdrop #402c17 
	across space 0x0 origin 8x8
	style sq: base 50x50 font-size 36 draw [
		font piece-font  pen #FFFFFF text 0x-7 ""  pen #000000 text 0x-7 ""
	]
		on-down :_on-down
		on-up   :_on-up
	style dk-sq: sq #835931
	style lt-sq: sq #cdb075
]

; words that refer to square faces
sq-names: copy []

; Build up a list of squares to consume when building the layout.
; Because of the alternating nature of the colors by row, it's
; not a single, simple /dup operation.
mk-dup: func [value count][append/dup copy [] value count]
lt-row: mk-dup [lt-sq dk-sq] 4
dk-row: mk-dup [dk-sq lt-sq] 4
squares: mk-dup compose [(lt-row) (dk-row)] 4

; Lettered cols go left to right; rows are numbered bottom to top
mk-sq-name: func [col row][to word! append form col (9 - row)]

; Given a name, return the index of the cell in the board map
get-map-val-from-sq: func [face [object!] "square"][get face/extra/path]
set-map-val-from-sq: func [face [object!] "square" val][set face/extra/path val]

; Build the board layout, made of square faces (lt-sq or dk-sq)
repeat y board-size/y [
	col: #"A"
	repeat x board-size/x [
		append sq-names ref: mk-sq-name col y				; 9 - y because rows go up from the bottom
		repend board-spec [
			to set-word! ref								; give the square a name to reference
			take squares									; take a square from our list, light or dark
			'extra object [									; not sure exactly how we'll use this yet
				name: ref									; e.g. A8 H1 D5
				path: to path! reduce ['cur-board-map y x]	; pointer into our current board map
				piece: none									; e.g. 'w/K 'b/Q
			]			
		]
		col: col + 1
	]
	append board-spec 'return
]


reset-board: does [
	cur-board-map: copy/deep new-board-map
	foreach face reduce sq-names [face/extra/piece: none]	; thinking we might store piece info there
	redraw-board
]
redraw-board: does [
	foreach face reduce sq-names [draw-piece face get-map-val-from-sq face]
]

;-------------------------------------------------------------------------------

aspect: board-size/x / to float! board-size/y
orientation: case [
	aspect > 1.25 [landscape]	; x / y > 1.25
	aspect < 0.80 [portrait]	; y / x > 1.25
	'else     	  [none]
]

switch/default orientation [
	landscape [
		; board on left, move history on right
	]
	portrait [
		; move history on top, board on bottom
	]
][
	; Don't show move history
]

;-------------------------------------------------------------------------------

system/view/auto-sync?: no			; We'll call SHOW when we want to update the UI

board: layout board-spec
view/no-wait board
reset-board
do-events
;print mold cur-board-map

;-------------------------------------------------------------------------------

Draws pieces now, but still hacking around with ideas.

Great start!