summaryrefslogtreecommitdiff
path: root/src/Thue/Interpreter.hs
blob: c3bdde243466b609673ad6e268c38e41ead5db3c (plain)
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
module Thue.Interpreter (
    thue,
    extractInfix,
    nextInRange
    ) where


import System.Random
import Data.Maybe
import Data.List
import Thue.Parser



data Choice = Random StdGen
            | First
            | Last



thue :: ThueProgram -> IO ThueState
thue program =
    let rules = thueRules program
        state = thueInitialState program
        version = thueVersion program
        gen = mkStdGen 4 --chosen by fair dice roll, guaranteed to be random

    in interpret version rules (Random gen) 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