never executed always true always false

    1 module HelVM.HelMA.Automata.BrainFuck.Common.TapeOfSymbols (
    2   triAndClearSymbol,
    3 
    4   mulDupAndClearSymbol,
    5   dupAndClearSymbol,
    6 
    7   mulAddAndClearSymbol,
    8   addAndClearSymbol,
    9   subAndClearSymbol,
   10 
   11   setSymbol,
   12   incSymbol,
   13   nextSymbol,
   14   prevSymbol,
   15   clearSymbol,
   16   writeSymbol,
   17 
   18   moveHead,
   19   moveHeadRight,
   20   moveHeadLeft,
   21 
   22   newTape,
   23   FullTape,
   24 ) where
   25 
   26 import           HelVM.HelMA.Automata.BrainFuck.Common.Symbol
   27 
   28 import           Control.Monad.Extra
   29 
   30 -- | Complex instructions
   31 
   32 triAndClearSymbol :: (Symbol e) => Integer -> Integer -> Integer -> FullTapeD e
   33 triAndClearSymbol f1 f2 f3 tape = tape & stepSymbol f1 & stepSymbol f2 & stepSymbol f3 & backAndClear back where
   34   back = negate (f1 + f2 + f3)
   35   stepSymbol = step symbol
   36   symbol = readSymbol tape
   37 
   38 mulDupAndClearSymbol :: (Symbol e) => Integer -> Integer -> Integer -> Integer -> FullTapeD e
   39 mulDupAndClearSymbol m1 m2 f1 f2 tape = tape & step ms1 f1 & step ms2 f2 & backAndClear back where
   40   back = negate (f1 + f2)
   41   ms1 = symbol * fromIntegral m1
   42   ms2 = symbol * fromIntegral m2
   43   symbol = readSymbol tape
   44 
   45 dupAndClearSymbol :: (Symbol e) => Integer -> Integer -> FullTapeD e
   46 dupAndClearSymbol f1 f2 tape = tape & stepSymbol f1 & stepSymbol f2 & backAndClear back where
   47   back = negate (f1 + f2)
   48   stepSymbol = step symbol
   49   symbol = readSymbol tape
   50 
   51 mulAddAndClearSymbol :: (Symbol e) => Integer -> Integer -> FullTapeD e
   52 mulAddAndClearSymbol mul forward tape = tape & step mulSymbol forward & backAndClear back where
   53   back = negate forward
   54   mulSymbol = symbol * fromIntegral mul
   55   symbol = readSymbol tape
   56 
   57 addAndClearSymbol :: (Symbol e) => Integer -> FullTapeD e
   58 addAndClearSymbol = changeAndClearSymbol id
   59 
   60 subAndClearSymbol :: (Symbol e) => Integer -> FullTapeD e
   61 subAndClearSymbol = changeAndClearSymbol negate
   62 
   63 changeAndClearSymbol :: (Symbol e) => (e -> e) -> Integer -> FullTapeD e
   64 changeAndClearSymbol f forward tape = tape & step symbol forward & backAndClear back where
   65   back = negate forward
   66   symbol = f $ readSymbol tape
   67 
   68 step :: (Symbol e) => e -> Integer -> FullTapeD e
   69 step symbol forward = addSymbol symbol . moveHead forward
   70 
   71 backAndClear :: (Symbol e) => Integer -> FullTapeD e
   72 backAndClear back = clearSymbol . moveHead back
   73 
   74 -- | Change symbols
   75 
   76 setSymbol :: (Symbol e) => Integer -> FullTapeD e
   77 setSymbol i = modifyCell $ const $ fromIntegral i
   78 
   79 incSymbol :: (Symbol e) => Integer -> FullTapeD e
   80 incSymbol i = addSymbol $ fromIntegral i
   81 
   82 addSymbol :: (Symbol e) => e -> FullTapeD e
   83 addSymbol e = modifyCell $ inc e
   84 
   85 clearSymbol :: (Symbol e) => FullTapeD e
   86 clearSymbol = modifyCell $ const def
   87 
   88 nextSymbol :: (Symbol e) => FullTapeD e
   89 nextSymbol = modifyCell next
   90 
   91 prevSymbol :: (Symbol e) => FullTapeD e
   92 prevSymbol = modifyCell prev
   93 
   94 writeSymbol :: (Symbol e) => Char -> FullTapeD e
   95 writeSymbol symbol = modifyCell (const $ fromChar symbol)
   96 
   97 modifyCell :: D e -> FullTapeD e
   98 modifyCell f (left , cell : right) = (left , f cell : right)
   99 modifyCell _ (_ , [])              = error "End of the Tape"
  100 
  101 readSymbol :: FullTape e -> e
  102 readSymbol (_ , cell : _) = cell
  103 readSymbol (_ , [])       = error "End of the Tape"
  104 
  105 -- | Moves
  106 
  107 moveHead :: (Symbol e) => Integer -> FullTapeD e
  108 moveHead = changeTape moveHeadRight moveHeadLeft
  109 
  110 changeTape :: FullTapeD e -> FullTapeD e -> Integer -> FullTapeD e
  111 changeTape lf gf i t = loop atc (i , t) where
  112   atc (i' , t') = (check . compare0) i' where
  113     check LT = Left (i' - 1 , lf t')
  114     check GT = Left (i' + 1 , gf t')
  115     check EQ = Right t'
  116 
  117 moveHeadRight :: (Symbol e) => FullTapeD e
  118 moveHeadRight (cell : left , right) = pad (left , cell : right)
  119 moveHeadRight ([] , _)              = error "End of the Tape"
  120 
  121 moveHeadLeft :: (Symbol e) => FullTapeD e
  122 moveHeadLeft (left , cell : right) = pad (cell : left , right)
  123 moveHeadLeft (_ , [])              = error "End of the Tape"
  124 
  125 pad :: (Symbol e) => FullTapeD e
  126 pad ([] , [])    = newTape
  127 pad ([] , right) = ([def] , right)
  128 pad (left , [])  = (left , [def])
  129 pad tape         = tape
  130 
  131 -- | Constructors
  132 
  133 newTape :: (Symbol e) => FullTape e
  134 newTape = ([def] , [def])
  135 
  136 -- | Types
  137 
  138 type D a = a -> a
  139 type FullTape e = (HalfTape e , HalfTape e)
  140 type FullTapeD e = D (FullTape e)
  141 
  142 type HalfTape e = [e]