第12回オフラインリアルタイムどう書くの参考問題をFregeで解く ref: http://qiita.com/uehaj/items/0e0e7979b7e2b19e55f5

turtle.fr

package sample.Turtle where

type Position = Char
type Direction = Char
type Command = Char

pure native elemIndex indexOf :: String -> Int -> Int

ewData :: String
ewData = "?"++packed ['A'..'K']++"?"++packed ['L'..'V']++"?"++packed ['W'..'Z']++packed ['a'..'g']++"?"
         ++"?hij?klm?nop?qrs?tuv?wxy?z01?234?567?"

nsData :: String
nsData = "?"++"ALWhknqtwz25"++"?"++"BMXilorux036"++"?"++"CNYjmpsvy147"
         ++ "?" ++"DOZ" ++ "?" ++ "EPa" ++ "?" ++ "FQb" ++ "?" ++ "GRc" ++ "?" ++ "HSd"
         ++ "?" ++ "ITe" ++ "?" ++ "JUf" ++ "?" ++ "KVg" ++ "?"

moveForward :: (Position, Direction, [Char]) -> Int -> (Position, Direction, [Char])
moveForward (pos, dir, hist) 0 = (pos, dir, hist)
moveForward ('7', 'S', hist) n = moveForward ('e', 'N', hist++['e']) (n-1)
moveForward ('6', 'S', hist) n = moveForward ('f', 'N', hist++['f']) (n-1)
moveForward ('5', 'S', hist) n = moveForward ('g', 'N', hist++['g']) (n-1)
moveForward ('e', 'S', hist) n = moveForward ('7', 'N', hist++['7']) (n-1)
moveForward ('f', 'S', hist) n = moveForward ('6', 'N', hist++['6']) (n-1)
moveForward ('g', 'S', hist) n = moveForward ('5', 'N', hist++['5']) (n-1)
moveForward (pos, dir, hist) n = moveForward nextState (n-1)
    where
          nextState :: (Char, Char, [Char])
          nextState = (nextPos, dir, hist++(nextPos:[]))
          nextPos :: Char
          nextPos = case dir of
                      'N' -> nextPosOf pos nsData (subtract 1)
                      'W' -> nextPosOf pos ewData (subtract 1)
                      'S' -> nextPosOf pos nsData (+1)
                      'E' -> nextPosOf pos ewData (+1)
          nextPosOf :: Char -> String -> (Int -> Int) -> Char
          nextPosOf c map f = let i=map `elemIndex` (ord c) in if (i/=0) then ((unpacked map) !! (f i)) else '?'

turnDir :: Direction -> String -> Position -> [Char] -> State (Position, Direction, [Char]) ()
turnDir dir dirs pos hist = State.put (pos, (let x=(dirs `elemIndex` (ord dir)) in ((unpacked dirs) !! (x+1))), hist)

oneStep :: Command -> State (Position, Direction, [Char]) ()
oneStep ch = do
  (pos, dir, hist) <- State.get
  case ch of
    'L' -> turnDir dir "ENWSE" pos hist
    'R' -> turnDir dir "ESWNE" pos hist
    _
          | ch `elem` ['1'..'9'] -> State.put (moveForward (pos, dir, hist) (ord ch-ord '0'))
          | ch `elem` ['a'..'f'] -> State.put (moveForward (pos, dir, hist) ((ord ch-ord 'a')+10))

solve :: [Command] -> [Position]
solve cmd = reduce hist
        where (_,_,hist) = (let (v,s) = State.run (mapM_ oneStep cmd) initialState in s)
              reduce [] = []
              reduce (xs:'?':_) = xs:(unpacked "?")
              reduce (x:xs) = x:(reduce xs)
              initialState = ('A','E',(unpacked "A"))

test cmd expected = do
    let result = packed $ solve (unpacked cmd)
    println $ result == expected

main args = do
    test "2RcL3LL22" "ABCNYjmpsvy147edcbcdef"  {- 0 -}
    test "L3R4L5RR5R3L5" "A?"  {- 1 -}
    test "2ReLLe" "ABCNYjmpsvy147eTITe741yvspmjYNC"  {- 2 -}
    test "1ReRRe" "ABMXilorux036fUJUf630xuroliXMB"  {- 3 -}
    test "ReRRe" "ALWhknqtwz25gVKVg52zwtqnkhWLA"  {- 4 -}
    test "f" "ABCDEFGHIJK?"  {- 5 -}
    test "Rf" "ALWhknqtwz25gVK?"  {- 6 -}
    test "1Rf" "ABMXilorux036fUJ?"  {- 7 -}
    test "2Rf" "ABCNYjmpsvy147eTI?"  {- 8 -}
    test "aR1RaL1LaR1R2L1L2" "ABCDEFGHIJKVUTSRQPONMLWXYZabcdefg567432"  {- 9 -}
    test "2R1R2L1L2R1R2L1L2R1R2L1L2R1R2L1L2" "ABCNMLWXYjihklmponqrsvutwxy"  {- 10 -}
    test "2R4R2L4L2R4R2L4L2R4R2L4L2" "ABCNYjmlknqtwxy147efgVK?"  {- 11 -}
    test "R1L2R4R2L4L2R4R2L4L2R4R2L4L2" "ALMNYjmponqtwz0147eTUVK?"  {- 12 -}
    test "R2L2R4R2L4L2R4R2L4L2R4R2L4L2" "ALWXYjmpsrqtwz2347eTIJK?"  {- 13 -}
    test "R3L2R4R2L4L2R4R2L4L2R4R2L4L2" "ALWhijmpsvutwz2567eTI?"  {- 14 -}
    test "R5L2L5L1LaR1L4L5" "ALWhknopmjYNCBMXilorux0325gVKJIHGF"  {- 15 -}
    test "1R2L4L2R4R2L4L2R4" "ABMXYZabQFGHIJUfg?"  {- 16 -}
    test "2R2L4L2R4R2L4L2R4" "ABCNYZabcRGHIJKVg?"  {- 17 -}
    test "3R2L4L2R4R2L4L2R4" "ABCDOZabcdSHIJK?"  {- 18 -}
    test "4R2L4L2R4R2L4L2R4" "ABCDEPabcdeTIJK?"  {- 19 -}
    test "5R2L4L2R4R2L4L2R4" "ABCDEFQbcdefUJK?"  {- 20 -}
    test "LLL1RRR1LLL1RRR2R1" "ALMXYZ?"  {- 21 -}
    test "R3RRR3" "ALWhij?"  {- 22 -}
    test "1LLL4RRR1LR1RL1" "ABMXilm?"  {- 23 -}
    test "R2L1R2L1R3R4" "ALWXilmpsvut?"  {- 24 -}
    test "7R4f47LLLc6R9L" "ABCDEFGHSd?"  {- 25 -}
    test "5RR868L8448LL4R6" "ABCDEFEDCBA?"  {- 26 -}
    test "42Rd1RLLa7L5" "ABCDEFGRc?"  {- 27 -}
    test "RRLL6RLR1L5d12LaLRRL529L" "ABCDEFGRSTUV?"  {- 28 -}
    test "RLR7L6LL1LRRRcRL52R" "ALWhknqtuv?"  {- 29 -}
    test "1RLR8RLR1R437L99636R" "ABMXiloruxwtqnkhWLA?"  {- 30 -}
    test "LLL2L3La9Le5LRR" "ALWXYZOD?"  {- 31 -}
    test "R1LcRR491" "ALMNOPQRSTUV?"  {- 32 -}
    test "R8L1R1R512L8RLLReRf" "ALWhknqtwx0z?"  {- 33 -}
    test "1RcL8f1L29a5" "ABMXilorux036fedcbaZYXW?"  {- 34 -}
    test "R822LeL46LL39LL" "ALWhknqtwz25gfedcbaZYXW?"  {- 35 -}
    test "9R3L5LRRLb5R3L7cLLLR4L" "ABCDEFGHIJUf65?"  {- 36 -}
    test "7LLRRR2R3R69Lf76eR2L" "ABCDEFGHSdcbaPE?"  {- 37 -}
    test "8RRRLL3Le" "ABCDEFGHITe765?"  {- 38 -}
    test "8R5RLL6LbL4LL5bL" "ABCDEFGHITe7410z?"  {- 39 -}
    test "6LR2R1LR5LRLRL484L63" "ABCDEFGHITe741yxw?"         {- 40 -}