1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
|
module Thue.Interpreter (
Choice(..),
thue,
extractInfix,
nextInRange
) where
import System.Random
import Data.Maybe
import Data.List
import Thue.Parser
data Choice = Random StdGen
| First
| Last
thue :: ThueProgram -> Maybe Choice -> IO ThueState
thue program order =
let rules = thueRules program
state = thueInitialState program
version = thueVersion program
gen = mkStdGen 4 --chosen by fair dice roll, guaranteed to be random
choice = if (isJust order) then fromJust order else Random gen
in interpret version rules choice state
interpret :: ThueVersion -> [ThueRule] -> Choice -> ThueState -> IO ThueState
interpret ver rules gen state =
let possibleRules = rules `applicableTo` state
(ruleToApply, gen') = choose possibleRules gen
in if (possibleRules == [])
then return state
else applyRule ver ruleToApply state >>= interpret ver rules gen'
choose :: [ThueRule] -> Choice -> (ThueRule, Choice)
choose ruleList gen =
case gen of
First -> (head ruleList, First)
Last -> (last ruleList, Last)
Random g -> let (num, g') = nextInRange 0 (length ruleList - 1) g
in (ruleList !! num, Random g')
applyRule :: ThueVersion -> ThueRule -> ThueState -> IO ThueState
applyRule ver rule state =
let (before, after) = fromJust (extractInfix (original rule) state)
inputProc = if (ver == Ver2a) then return . tLitStr else return . tStr
in case (replacement rule) of
x | x == (tStr ":::") ->
getLine >>= inputProc >>= return . (before ++) . (++ after)
x:xs | x == (tCh '~') ->
putStr (fromThueState xs) >> return (before ++ after)
x -> return (before ++ x ++ after)
extractInfix :: Eq a => [a] -> [a] -> Maybe ([a], [a])
extractInfix subList list =
let f = (\pre cur -> case (stripPrefix subList cur) of
Nothing -> f ((head cur):pre) (tail cur)
Just x -> (reverse pre, x))
in if (subList `isInfixOf` list) then Just (f [] list) else Nothing
nextInRange :: Int -> Int -> StdGen -> (Int, StdGen)
nextInRange low high random =
let (genLow, genHigh) = genRange random
(rawNext, random') = next random
irawNext = fromIntegral rawNext
igenLow = fromIntegral genLow
igenHigh = fromIntegral genHigh
ilow = fromIntegral low
ihigh = fromIntegral high
n' = ((irawNext - igenLow) / (igenHigh - igenLow)) * (ihigh - ilow) + ilow
in (round n', random')
applicableTo :: [ThueRule] -> ThueState -> [ThueRule]
applicableTo ruleList state =
filter (\r -> (original r) `isInfixOf` state) ruleList
|
