Graphical Red Towers of Hanoi

view-hanoi.red

Red [
	File:   %view-hanoi.red
	Author: "Gregg Irwin"
	Date:   "4-Oct-2001 — 26-Jun-2016"
	Needs:  View
]

num-disks: 5    	; Have to set this here until it gets into the UI.
disk-height: 15
disk-cell-width: 20	; Smallest disk is 1 cell wide
wait-time: 0    	; .05 *Really* slow. Anything more would be painful. Try .001.

tower-top: 50
tower-height: disk-height * (num-disks + 2)
towers: none
num-moves: 0

; You can use different values for each direction
move-offset: [up 0x-1  down 0x1  left -1x0  right 1x0]

start: func [
	num-disks [integer!] "Number of disks to play with"
][
	tower-height: disk-height * (num-disks + 1)
	num-moves: 0
	; The three towers, each with a list of disk numbers on them
	towers: reduce [make-disks num-disks copy [] copy []]	; Disks start on tower 1
	do-towers num-disks 1 2 3
	;print ["Number of moves required: " num-moves]
]

bottom: func [face][face/offset/y + face/size/y]

center: function [face /x /y][
	res: add face/offset divide face/size 2
	either x [ res/x ][ either y [res/y][res] ]
]

disk-name: func [num][to word! append form "D" num]
disk-sz: func [cells][as-pair disk-wd cells disk-height]
disk-wd: func [cells][disk-cell-width * cells]

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

do-towers: func [
	num-disks [integer!] "Number of disks to move"
	source    [integer!] "Source tower"
	temp      [integer!] "Temporary holding tower"
	dest      [integer!] "Destination tower"
][
	if num-disks > 0 [
		do-towers (num-disks - 1) source dest temp
		; If you don't want to see the disks move, comment out the next line.
		animate-disk-move source dest
		move-disk towers/:source towers/:dest
		do-towers (num-disks - 1) temp source dest
	]
]

make-disks: function [
	num-disks [integer!] "Number of disks to put in a block"
][
	reverse collect [repeat i num-disks [keep i]]
]

move-disk: func [
	source [block!] "Source tower"
	dest   [block!] "Destination tower"
][
	num-moves: add num-moves 1
	append dest take/last source
]

process-events: does [loop 2 [do-events/no-wait]  wait wait-time]
	
;-------------------------------------------------------------------------------

animate-disk-move: function [
	"Animate a disk moving from a source tower to a dest tower."
	source [integer!] "Tower number"
	dest   [integer!] "Tower number"
][
	disk-face: get disk-name last towers/:source
	if object? disk-face [
		animate-disk-up   disk-face
		animate-disk-over disk-face source dest
		animate-disk-down disk-face dest
	]
]

move-face: func [face way][face/offset: face/offset + move-offset/:way]

move-while: func [test face way][
	while test [move-face face way  process-events]
]

animate-disk-up: function [disk-face][
	move-while [tower-top <= bottom disk-face] disk-face 'up
]

animate-disk-down: function [disk-face dest][
	dest-y: (tower-top + tower-height) - (((length? towers/:dest) - 1) * disk-height)
	move-while [dest-y > bottom disk-face] disk-face 'down
]

animate-disk-over: function [disk-face source dest][
	dest-x: 5 + tower-x-pos dest				; + 5 accounts for 1/2 tower width
	way: either source < dest ['right]['left]
	cmp: either source < dest [:lesser?][:greater?]
	move-while [cmp (center/x disk-face) dest-x] disk-face way
]

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

tower-x-pos: func [index][
	50 + ((disk-wd num-disks + 1) * (index - 1)) + ((disk-wd num-disks) / 2)
]

initial-disk-x-pos: func [index][
	(5 + tower-x-pos 1) - ((disk-wd index) / 2)	; + 5 accounts for 1/2 tower width
]

make-disk: func [num-cells /local color][
	compose/deep [
		disk (disk-sz num-cells) draw [
			pen red fill-pen linear 0x0 0 (disk-wd num-cells) 0 1 1 red 96.0.0
			box 0x0 (disk-sz num-cells)
		]
	] 
]

; Base layout, to which we add the towers and disks.
lay: compose/deep [
	; We need to set the size, to get enough padding on the right side.
	; VIEW doesn't know we're going to move a larger disk over there.
	size (as-pair ((disk-wd num-disks + 1 * 3) + 100) (tower-height + 100))
	; Define tower and disk face styles
	style tower: base (as-pair 10 tower-height) draw [
		pen coal fill-pen linear 0x0 0 10 0 1 1 brick coal
		box 0x0 (as-pair 10 tower-height)
	]
	style disk: base 							; All other details generated dynamically
	across
]
; Add Towers
repeat i 3 [
	append lay compose [at (as-pair (tower-x-pos i) tower-top) tower]
]
; Add Disks
repeat i num-disks [
	append lay compose [
		at (as-pair (initial-disk-x-pos i) (tower-top + ((i + 1) * disk-height)))
		(to set-word! form disk-name i) (make-disk i)
	]
	set disk-name i none					; Make global var for compiler to see
]
; Add command buttons
append lay [
	return
	button "go" [start num-disks]
	button "close" [quit]
]

view layout lay

The minus "—" is causing the trouble for me.
When unview is used, the cursor does not come back in the console so a 'quit is needed.
The problem with cut-off disks looks gone now.