cryptarithm.red

Red [
	Author: "Toomas Vooglaid"
	Date: 2017-10-23
]
context [
	A: B: C: D: E: F: G: H: I: J: K: L: M: N: O: P: Q: R: S: T: U: V: W: X: Y: Z: none
	numbers: 	 make block!  10
	nums: 		 make block!  10
	out: 		 make block!  10
	letters: 	 make block!  10
	ltrs: 		 make block!  10
	calculation: make block!  10
	constricted: make block!  10
	expressions: make block!  15
	words: 		 make string! 100
	product: func [block coeficients][
		out: clear out 
		forall block [append out block/1 * coeficients/(index? block)] 
		out
	]
	summa: func [block /local out][out: 0 forall block [out: out + block/1]]
	to-number: func [nums-block /local coeficients i][
		coeficients: clear []
		repeat i length? nums-block [insert coeficients 10 ** (i - 1)]
		summa product nums-block coeficients
	]
	to-formula: func [word /local letter][
		ltrs: clear ltrs
		foreach letter to-string word  [
			append ltrs to-word letter
		]
		append letters bind ltrs self
		to-paren append/only copy [to-number reduce] copy ltrs
	]
	make-val: func [op val /local item][
		switch op [
			>  [copy/part next find numbers val tail numbers]
			>= [copy/part find numbers val tail numbers]
			<  [copy/part head numbers find numbers val]
			<= [copy/part head numbers next find numbers val]
			<> [remove-each item nums: copy numbers [find to-block val item] nums]
			in [val]
			is [case [
				val = 'odd  [remove-each item nums: copy numbers [even? item] nums]
				val = 'even [remove-each item nums: copy numbers [ odd? item] nums]
			]]
		]
	]
	alnum: charset [#"a" - #"z" #"A" - #"Z" #"0" - #"9" #" "]
	set 'alphametic func [text [string!] /heuristics heur /local riddle start mid][
		words: clear words
		parse text [
			collect into words some [
				keep alnum
			|	skip
			]
		]
		riddle: parse load words [
			start: collect some [
				mid: if (start = mid) [keep word!] 
			| 	[	if (1 = length? mid) keep ('=) keep word! 
				| 	keep ('+) keep word!
				]
			]
		] 
		either heuristics [
			solve/heuristics riddle heur
		][
			solve riddle
		]
	]
	set 'solve func [riddle [block! string!] /heuristics heur /local word key op val block start][
		either (string? riddle) [
			either heuristics [alphametic/heuristics riddle heur][alphametic riddle]
		][
			A: B: C: D: E: F: G: H: I: J: K: L: M: N: O: P: Q: R: S: T: U: V: W: X: Y: Z: none
			numbers: 	 copy  [0 1 2 3 4 5 6 7 8 9]	
			letters: 	 clear letters
			calculation: clear calculation
			constricted: clear constricted
			expressions: clear expressions
			parse riddle [
				collect into calculation some [
					keep [ '* | '/ | '+ | '- | '** | '= ]  
				|	keep integer!
				| 	set word word! keep (to-formula word)
				]
			]
			letters: unique letters
			if heuristics [
				foreach [key op val] heur [
					unless block? key [key: to-block key]
					bind key self
					forall key [alter letters key/1] 
					case [
						not empty? intersect letters to-block val [; for expressions like: A = [B + 1] or [A B] > [C + D]...
							append expressions reduce [key op bind to-block val self]
						]
						equal? op '= [
							set key val: to-block val 
							forall val [alter numbers val/1]
						]
						true [
							append constricted reduce [key make-val op val]
						]
					]
				]
			]
			start: now/time
			either until [
				if 00:00:30 < (now/time - start) [break/return false]
				unless empty? expressions [
					foreach [key op val][
						set ltrs: unique intersect letters val random numbers
						forall ltrs [alter letters ltrs/1]
						;... TBD
					]
				]
				unless empty? constricted [
					foreach [key val] constricted [
						set key random val 
						forall key [alter numbers get key/1]
					]
				] 
				set letters random numbers 
				unless empty? constricted [
					foreach [key val] constricted [
						forall key [alter numbers get key/1]
					]
				]
				all reduce calculation
			][
				compose calculation
			][
				"Time-out after 30 seconds! Try to improve heuristics."
			]
		]
	]
]
comment {
	solve/heuristics [SEND + MORE = MONEY][[M S] = [1 9]]
	solve/heuristics [FORTY + TEN + TEN = SIXTY][N = 0 E = 5 [S T F] >= 1]
	solve/heuristics [NUMBER + NUMBER = PUZZLE][[N P] > 0 E is even]
	solve/heuristics [TILES + PUZZLES = PICTURE][[P T] > 0 E is even]; may take long
	solve/heuristics [CLOCK + TICK + TOCK = PLANET][P = 1 T <> [0 4] C >= 2]
	solve/heuristics [COCA + COLA = OASIS][O = 1 S is even]
	HERE + SHE = COMES
	DOUBLE + DOUBLE + TOIL = TROUBLE
	NO + GUN + NO = HUNT
	THREE + THREE + TWO + TWO + ONE = ELEVEN
	CROSS + ROADS = DANGER
	MEMO + FROM = HOMER
	WOW + WOW + WOW + WOW + WOW = MEOW 
	YES + LETS + ALL + TRY + A + FUNNY = TEASER
	O * SEE = EMOO S * SEE = MESS EMOO + MESS = MIMEO
	
	Added `*` and `/` as operators
	      S E E
	*       S O
	-----------
	    E M O O
	+ M E S S
	-----------
	  M I M E O
	
	solve/heuristics [O * SEE = EMOO S * SEE = MESS 10 * MESS + EMOO = MIMEO][[S E] = [9 1]]
	solve/heuristics [SO * SEE = MIMEO 10 * MESS + EMOO = MIMEO][[S E] = [9 1]]
	
	Try these:
	      A S S
	*       A S
	-----------
	    A L S O
	+ R O S E
	-----------
	  A L L O O
	===========
	      S A Y
	*       M Y
	-----------
	    N A M E
	+ A M N E
	-----------
	  S T Y L E
	
	Added `**`
	
	solve [AA ** B = ABA]
	solve [AB ** B = ACC]
	
	See e.g.:
    	http://www.cut-the-knot.org/cryptarithms/st_crypto.shtml
    	http://www.cryptarithms.com/
    	http://cryptarithms.awardspace.us/puzzles.html
    	http://www.contestcen.com/rithms.htm
	
		Added alphametic:
	
	alphametic/heuristics "Who is this idiot?" [[i t] = [1 9] W >= 2]
	also:
	solve/heuristics "Who is this idiot?" [[i t] = [1 9] W >= 2]
	
	Try these: (I haven't tried these yet. In case of problems, please let me know.)
		Fifty states: America.
		Terrible number thirteen.
		Earth, air, fire, water: nature.
		Saturn, Uranus, Neptune, Pluto: planets.
		Georgia, Oregon, Vermont, Virginia.
		Winter breeze bred bitter freeze.
		Winter is windier, summer is sunnier.
		No snow in view on roofs in Venice.
		Martin Gardner retires.
		Nathan ate green peppers.
		Amelia peeled a banana.
		Romans also more or less added letters.
		Gee, I see a rare magic square.
		Scientific American master creates frenetic interest in IMF metric (tens) state: fantastica!
	
	See: http://www.cadaeic.net/alphas.htm
}