bf-hs-codegen/GenericSteps.hs at master · dsche/bf-hs-codegen · GitHub

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
import Data.List

data Command = Nop | Loop [(Int, Command)]

isLoop :: Command -> Bool
isLoop (Loop _) = True
isLoop _ = False

type Program = ([(Int, Structure)], [(Int, Command)])

data Structure = BoundedTape | Register | InfBoundedTapes | Tape
     deriving (Ord, Enum, Eq)

reduce :: Structure -> [Structure]
reduce Register = [BoundedTape]
reduce InfBoundedTapes = [BoundedTape, BoundedTape, BoundedTape, BoundedTape, Register]
reduce Tape = [InfBoundedTapes]

freshTapes :: Program -> Int -> [Structure] -> (Program, [Int])
freshTapes p _ [] = (p, [])
freshTapes (structs, cmds) oldIdx (s:ss) = (p, oldIdx:is)
  where (p, is) = freshTapes (structs', cmds) idx ss
        structIndexes = sort $ (map fst structs)
        structs' = (oldIdx, s) : (case oldIdx `elem` structIndexes of
                                     True -> filter ( (/= oldIdx) . fst ) structs
                                     False -> structs )
        idx = head $ [1..] \\ structIndexes

compileSingle :: Structure -> Command -> [Int] -> [(Int, Command)]
compileSingle = undefined -- TODO: Specify

mapSingle :: Structure -> Int -> Program -> Program
mapSingle struct idx p@(structs, cmds) = (structs', cmds')
  where newStructs = reduce struct
        ((structs', _), idxs) = freshTapes p idx newStructs
        cmds' = concat $ map (\(i, c) ->
                               case i == idx of
                                 True -> compileSingle struct c idxs
                                 False -> [(i, c)] ) cmds

reorderStep :: Program -> Program
reorderStep (structs, cmds) = (structs, untangledInit ++ ( case restCommands of
                                                                       [] -> []
                                                                       ((i, Loop l):rs) -> (i, Loop (snd $ reorderStep (structs, l))) : (snd $ reorderStep (structs, rs))
                                                                       _ -> [] ) )
  where initCommands = takeWhile (not . isLoop . snd) cmds
        restCommands = dropWhile (not . isLoop . snd) cmds
        struct idx = snd $ head $ filter ( (==idx) . fst) structs
        reorderedInit = sortBy (\ (ix, cmd) (ix', cmd') ->
                                 case (compare (struct ix) (struct ix'), compare ix ix') of
                                   (GT, _) -> LT
                                   (LT, _) -> GT
                                   (EQ, x) -> x) initCommands
        zippedInit = map ( \(i,c) -> (i, (struct i), c) ) reorderedInit
        partitionedInit = partitioned' [] zippedInit
        partitioned' acc [] = [acc]
        partitioned' [] (x:xs) = partitioned' [x] xs
        partitioned' (y@(_, s, _):ys) (x@(_, s', _):xs) = case s == s' of
          True -> partitioned' (y:ys ++ [x]) xs
          False -> (y:ys) : partitioned' [x] xs
        optimizedInit = concat $ map optimize partitionedInit
        untangledInit = map ( \(i, _, c) -> (i, c) ) optimizedInit

compileStep :: Program -> Program
compileStep p@(structs, cmds) = case maxLevelStructs of
  (x:xs) -> mapSingle (snd x) (fst x) p
  [] -> p
  where maxLevelStructs = filter ( (==maxLevel) . snd ) structs
        maxLevelCommands = filter ( (flip elem) (map fst maxLevelStructs) . fst ) $ cmds
        maxLevel = maximum $ map snd structs
        struct idx = snd $ head $ filter ( (==idx) . fst) structs
--        computedInit = map (\(idx, cmd) -> (idx, struct idx, cmd) ) initCommands


optimize :: [(Int, Structure, Command)] -> [(Int, Structure, Command)]
optimize = id