Skip to content

Instantly share code, notes, and snippets.

@toomasv
Last active October 27, 2017 22:39
Show Gist options
  • Save toomasv/c63e49e26d2cfb6032db9d0428029e3d to your computer and use it in GitHub Desktop.
Save toomasv/c63e49e26d2cfb6032db9d0428029e3d to your computer and use it in GitHub Desktop.
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
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment