#!/usr/bin/rebol
REBOL [
	title: "Sudoku-bol"
	author: "Frank Sievertsen"
	purpose: "Sudoku Solver and Gererator"
	version: 1.0.3
	comments: {
		Divided cleanly into the game-engine (sudoku-game object) and the gui.
		
		Both written by me, I put them into one file for simple distribution.
		
		sudoku-game object has some additional functions to make it easy to use in other programs. (printout, readin for example)
		
		You can use this program to solve the sudoku-game in your newspaper, too.
		
		Now with undo and redo.
	}
]

random/seed now

sudoku-game: context [
	board: array 9 * 9
	
	column: func [
		"Returns a column of the board"
		num [integer!]
		/local out
	] [
		if any [
			num < 0
			num > 9
		] [
			make error! "column"
		]
		extract (at board num) 9
	]
	
	row: func [
		"Returns a row of the board"
		num [integer!]
	] [
		if any [
			num < 0
			num > 9
		] [
			make error! "row"
		]
		copy/part skip board num - 1 * 9 9
	]
	field: func [
		"Returns the values of a 3x3 field"
		num [integer!]
		/local x y out
	] [
		x: num - 1 // 3 + 1
		y: (to-integer num - 1 / 3) * 3 + 1
		out: copy []
		for z y (y + 2) 1 [
			append out copy/part skip row z (x - 1 * 3) 3
		]
		out
	]
	
	one9: func [
		"Returns the numbers 1 - 9 randomized, used to implement the generator"
	] [
		random [1 2 3 4 5 6 7 8 9]
	]

	legal?: func [
		"Is the block (3x3, line or row) ok?"
		block [block!]
		/local x pos
	] [
		repeat x 9 [
			pos: block
			if pos: find block x [
				if find next pos x [return false]
			] 
		]
		true
	]
	
	all-legal?: func [
		"Are all lines, rows and 3x3-field ok?"
	] [
		repeat x 9 [
			if not all [
				legal? row x
				legal? column x
				legal? field x
			] [return false] 
		]
		true
	]
	
	full?: func [
		"Is the board filled up?"
	] [
		not find board none
	]
	
	step: func [
		"returns all possibilities to add a number to the first free cell on the board"
		/local x pos out neu poses
	] [
		if full? [return copy []]
		
		pos: index? find board none
		out: copy []
		
		repeat z one9 [
			poke board pos z
			if all-legal? [append out make self []]			
		]
		poke board pos none
		
		out
	]

	get-xy: func [
		"returns cell-number for x,y"
		x [integer!]
		y [integer!]
	] [
		y - 1 * 9 + x
	]
	
	get-xy-val: func [
		"returns cell for x,y"
		x [integer!]
		y [integer!]
	] [
		pick board get-xy x y
	]
	
	field-xy: func [
		"Retuns the 3x3-field around x,y"
		x y
		/local z
	] [
		field (to-integer y - 1 / 3) * 3 + (to-integer x - 1 / 3) + 1
	]
	

	solve: func [
		{Solve the game by depth-first left-to-right and backtracking
		 and uses 'deduce to speedup process}

		/callback
			cb [function!]
		
		/local bag tester fertig not-deduce
	] [
		fertig: copy []
		if not all-legal? [return none]
		bag: reduce [self]
		not-deduce: 0
			; Not-decuce prevents the solver from beeing slowed down by the deducer
			; when it is unable to deduce
		forever [
			if empty? bag [return none]
			tester: last bag
			if callback [cb tester]
			if tester/full? [return tester]
			either all [not-deduce <= 0 deduce] [
				; Conclude ok
			] [
				; Conclude fail
				
				if not-deduce <= 0 [not-deduce: 10]
				not-deduce: not-deduce - 1
				remove back tail bag	
				append bag tester/step step
			]
		]
	]
	
	comment {
		Speedup-Functions, you could replace them by
			decuce: none
		while step only fills in numbers by trial and error and backtracking,
		this one tries to fill in the correct numbers in every step.
	}
	
	deduce: func [
		"Tries to fill in a number in a free cell by searching for fields where only one number is allowed"
		/local p1 p2 p3 t1 t2
	] [
		repeat y one9 [
			p1: copy []
			p2: copy []
			p3: copy []
			repeat x one9 [
				repend p1 [y x]
				repend p2 [x y]
			]
			repeat y2 3 [ repeat x2 3 [
				repend p3 [
					(y - 1 // 3) * 3 + x2
					(to-integer y - 1 / 3) * 3 + y2 
				]
			]]

			if t1: any [
				deduce2 p1
				deduce2 p2
				deduce2 p3
			] [return t1]
		]
		false
	]
	
	deduce2: func [
		coordinates
		/local count mem
	] [
		repeat z one9 [
			count: 0
			foreach [x y] coordinates [
				if none? pick board get-xy x y [
					poke board get-xy x y z
					if all [
						legal? row y
						legal? column x
						legal? field-xy x y
					] [
						count: count + 1
						mem: reduce [x y]
					]
					poke board get-xy x y none
				]
			]
			if count = 1 [
				poke board get-xy mem/1 mem/2 z
				return true
			]
		]
	]
	
	
	printout: func [
		"Returns a string with a representation of the board"
		/local out
	] [
		out: copy ""
		repeat z 9 [
			append out form replace/all row z none "?"
			append out newline
		]
		out
	]
	readin: func [
		"Takes a string with the representation of the board and insertes it into the board"
		str [string!]
		/local c
	] [
		str: copy str
		str: trim/all str
		if (length? str) <> (9 * 9) [make error! "readin"]
		if not find charset [#"1" - #"9" "?"] str [make error! "readin"]
		c: 0
		foreach chr str [
			c: c + 1
			either chr = #"?" [
				poke board c none
			] [
				poke board c to-integer to-string chr
			]
		
		]
	]
	empty: func [
		"How many fields are empty?"
		/local p c
	] [
		p: board
		c: 0
		while [p: find p none] [
			p: next p
			c: c + 1
		]
		c
	]
	
	removing?: no			; Is the generator removing numbers?
	
	generate: func [
		"The generator is quite simple, because i randomized the solver"
		empty [integer!] "Number of empty fields on the board"
		
		/callback
			cb [function!]
		/local mem mem2 count t xy x y pos
	] [
	
		removing?: no
		
		; First we solve an empty board
		
		pos: board
		forall pos [pos/1: none]
		
		t: either callback [solve/callback :cb] [solve]
		
		removing?: yes
		
		; Now we remove numbers as long as we can still use deduce to solve the board
		board: t/board
		count: 0
		xy: copy []
		repeat x one9 [
			repeat y one9 [
				repend/only xy [x y]
			]
		]
		xy: random xy
		foreach xy xy [
				x: xy/1 y: xy/2
				either callback [cb self]
				mem: copy board
				poke board y - 1 * 9 + x none
				mem2: copy board
				count: count + 1
				either loop count [if not deduce [break/return none] 1] [
					board: mem2
				] [
					board: mem
					count: count - 1
				]	
				if count >= empty [break]
		]
		self
	]
	
]


; AND NOW THE GUI

undos: copy []
redos: copy []

save-undo: func [] [
	clear redos
	if any [
		empty? undos
		(last undos) <> sudoku-game/board
	] [append/only undos copy sudoku-game/board]
]

undo: func [/local val] [
	if any [
		empty? redos
		(last redos) <> sudoku-game/board
	] [append/only redos copy sudoku-game/board]
	
	while [not empty? undos] [
		val: last undos
		remove back tail undos
		if val <> sudoku-game/board [
			sudoku-game/board: val
			show sudoku-panel
			exit
		]
	]
]
redo: func [/local tmp] [
	tmp: redos redos: undos undos: tmp
	undo
	tmp: redos redos: undos undos: tmp
]

active-sudoku-cell: none
sudoku-styles: stylize [
	sudoku-cell: txt
				40x40
				edge [size: 2x2]
				font [
					size: 20
					align: 'center
					valign: 'middle
				]
				with [
					sudoku-offset: func [] [offset / (size + 20x20) + 1x1]
					state: no
					highlight: no
					locked: no
				]
				feel [
					redraw: func [face action] [
						face/text: form any [
						     sudoku-game/get-xy-val
							(first face/sudoku-offset)
							(second face/sudoku-offset)
						     ""
						]
						face/edge/effect: pick [ibevel bevel] face/state
						face/color: if face/highlight [red + 200.200.200]
						
						face/font/color: pick [0.0.0 0.0.250] face/locked
						system/view/caret: tail face/text
						system/view/highlight-start: face/text
						system/view/highlight-end: tail face/text
					]
					engage: func [face action event /local offset] [
						if action = 'down [
							focus face
							if active-sudoku-cell [
								active-sudoku-cell/state: no
								show active-sudoku-cell
							]
							face/state: yes
							active-sudoku-cell: face
							show face
						]
						if action = 'key [
							if all [
								find "^H^~ " event/key
								not face/locked
							] [
								save-undo
								poke
									sudoku-game/board
									sudoku-game/get-xy
										(first face/sudoku-offset)
										(second face/sudoku-offset)
									none
								show face
							]
							if all [
								find "123456789" event/key
								not face/locked
							] [
								save-undo
								poke
									sudoku-game/board
									sudoku-game/get-xy
										(first face/sudoku-offset)
										(second face/sudoku-offset)
									to-integer to-string event/key
								show face
							]
							if offset: select [
								up 0x-1
								left -1x0
								down 0x1
								right 1x0
							] event/key [
								foreach f face/parent-face/pane [
									if face/size + 20 * offset + face/offset = f/offset [
										f/feel/engage f 'down none
										break
									]
								]
							]
						]
					]
				]

	sudoku-col: image 4x520 100.100.200
	
	sudoku-row: sudoku-col with [size: reverse size]
]


layout-def: copy [
	across
	space 20
	origin 10
	
	styles sudoku-styles
]

loop 9 [
	loop 9 [
		append layout-def [sudoku-cell]
	]
	append layout-def [return]
]

repeat z 2 [
	offset: sudoku-styles/sudoku-cell/size + 20 * z * 3 - 12
	append layout-def compose [
		at (offset * 1x0 + 10) sudoku-col
		at (offset * 0x1 + 10) sudoku-row
	]
]

generate-hardness: 20

view layout [
	style tog tog 130
	style btn btn 130
	
	at 10x10
	sudoku-panel: panel 540x540 layout-def
	return
	drop-down "Beginner" "Advanced" "Expert" 130 [error? try [
		generate-hardness: pick [20 35 50] index? find face/list-data value
	]]
	btn "Generate board" #"^G" [use [c prg new] [
		save-undo
		win: view/new center-face layout [
			txt "Generating board..."
			prg: progress 300	
		]
		c: 0
		new: sudoku-game/generate/callback generate-hardness func [t] [
			c: c + 1
			if c // 10 = 0 [
				either t/removing? [
					prg/data: (t/empty / 50) / 2 + ,5
				] [
					prg/data: (81 - t/empty) / 81 / 2
				]
				show prg
				wait 0
			]
		]
		unview/only win
		either new [
			sudoku-game: new
		] [
			request/ok "Generation failed."
		]
		show sudoku-panel
		lock-tog/state: lock-tog/data: yes
		show lock-tog
		do-face lock-tog yes
	]]
	btn "Solve board" #"^S" [use [c prg new win] [
		save-undo
		win: view/new center-face layout [
			txt "Solving..."
			prg: progress 300	
		]
		c: 0
		new: sudoku-game/solve/callback func [t] [
			c: c + 1
			if c // 40 = 0 [
				prg/data: (81 - t/empty) / 81
				show prg
				wait 0
			]
		]
		unview/only win
		either new [
			sudoku-game: new
		] [
			request/ok "Not solvable."
		]
		show sudoku-panel
	]]
	lock-tog: tog "Lock" "Unlock" [
		foreach face sudoku-panel/pane [
			if face/style = 'sudoku-cell [
				either value [
					face/locked: face/text <> ""
				] [
					face/locked: no
				]
				show face
			]
		]
	]
	
	btn "Clean up board" #"^C" [
		save-undo
		repeat z 9 * 9 [
			if not get in (pick sudoku-panel/pane z) 'locked [
				poke sudoku-game/board z none
			]
		]
		show sudoku-panel
	]
	
	btn "Give hint" #"^H" [use [tmp-game count f] [
		tmp-game: make sudoku-game []
		repeat z 9 * 9 [
			f: pick sudoku-panel/pane z
			f/highlight: no
			show f
		]
		either tmp-game/deduce [
			count: 0
			until [
				count: count + 1
				(pick tmp-game/board count) <> (pick sudoku-game/board count)
			]
			f: pick sudoku-panel/pane count
			f/highlight: yes
			f/feel/engage f 'down none
			show f
		] [
			request/ok "Hint not found, sorry."
		]
	]]
	panel 150x22 [
		style btn btn 60
		across
		btn "Undo" #"^Z" [undo]
		btn "Redo" #"^Y" [redo]
	]
	;pad 0x10
	panel 40x32 * 3x4 - 10x10 [
		space 10
		style num-btn btn 30 [use [val] [
			if active-sudoku-cell [
				val: #" "
				if find "123456789" first face/text [
					val: first face/text
				]
				active-sudoku-cell/feel/engage active-sudoku-cell 'key make object! [
					key: val
				]
			]
		]]
		across
		num-btn "1" num-btn "2" num-btn "3"
		return
		num-btn "4" num-btn "5" num-btn "6"
		return
		num-btn "7" num-btn "8" num-btn "9"
		return
		num-btn "CLR" 80
	]
	
	;pad 0x10
	
	txt 160 {
		Welcome to sudoku-bol. Use the generate-button to make a new board. You can use the solve-button
		to solve the game. The lock-button will lock/unlock all used board-cells. The hint-button will shows a cell to start with. Use can control the program by keyboard (1-9, space, cursor-keys) or by mouse (see buttons above). Have fun, Frank (FX5)
	}
]