never executed always true always false

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