packages feed

Fungi 1.0.5 → 1.0.6

raw patch · 68 files changed

+5221/−1 lines, 68 files

Files

Fungi.cabal view
@@ -9,7 +9,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             1.0.5+version:             1.0.6  -- A short (one-line) description of the package. synopsis:            Funge-98 interpreter written in Haskell@@ -57,6 +57,75 @@      -- Directories containing source files.   hs-source-dirs:      src++  other-modules:+        Data.ByteSize+        Data.Deque+        Data.History+        Data.I+        Data.IntegralLike+        Data.Labeled+        Data.LogicalBits+        Data.MaybeBounded+        Data.Stack+        Data.StackSet+        Data.Tuple.Map+        Data.Vector+        Debug.Debug+        Debug.Debugger+        Env+        Fingerprint+        Fingerprint.BASE+        Fingerprint.BF93+        Fingerprint.BOOL+        Fingerprint.BZRO+        Fingerprint.CPLI+        Fingerprint.FIXP+        Fingerprint.HRTI+        Fingerprint.MODE+        Fingerprint.MODU+        Fingerprint.NOP+        Fingerprint.NULL+        Fingerprint.ORTH+        Fingerprint.RECD+        Fingerprint.REFC+        Fingerprint.ROMA+        Fingerprint.STRN+        Fungi+        Instruction+        Interpreter+        Ip+        Math+        Mode+        ProcessArgs+        Random+        Semantics+        Space.Cell+        Space.Space+        System.IO.Buffering+        Text.Help.Debug+        Text.Help.Fingerprint+        Text.Help.Fungi+        Text.Help.Fingerprint.BASE+        Text.Help.Fingerprint.BF93+        Text.Help.Fingerprint.BOOL+        Text.Help.Fingerprint.BZRO+        Text.Help.Fingerprint.CPLI+        Text.Help.Fingerprint.FIXP+        Text.Help.Fingerprint.HRTI+        Text.Help.Fingerprint.MODE+        Text.Help.Fingerprint.MODU+        Text.Help.Fingerprint.NOP+        Text.Help.Fingerprint.NULL+        Text.Help.Fingerprint.ORTH+        Text.Help.Fingerprint.RECD+        Text.Help.Fingerprint.REFC+        Text.Help.Fingerprint.ROMA+        Text.Help.Fingerprint.STRN+        Text.PrettyShow+        Text.PrintOption+        UnknownInstruction+        Version
+ src/Data/ByteSize.hs view
@@ -0,0 +1,30 @@+module Data.ByteSize (+    ByteSize (..)+  ) where++import Data.Bits+import Data.Int++-----------------------------------------------------------++class ByteSize a where+  byteSize :: a -> Maybe Int++instance ByteSize Integer where+  byteSize _ = Nothing++instance ByteSize Int where+  byteSize _ = Just $ bitSize (0 :: Int) `div` 8++instance ByteSize Int8 where+  byteSize _ = Just $ bitSize (0 :: Int8) `div` 8++instance ByteSize Int16 where+  byteSize _ = Just $ bitSize (0 :: Int16) `div` 8++instance ByteSize Int32 where+  byteSize _ = Just $ bitSize (0 :: Int32) `div` 8++instance ByteSize Int64 where+  byteSize _ = Just $ bitSize (0 :: Int64) `div` 8+
+ src/Data/Deque.hs view
@@ -0,0 +1,86 @@+module Data.Deque (+    Deque+  , mkDeque+  , mkDeque1+  , isEmpty+  , depth+  , Data.Deque.toList+  , pop+  , popBottom+  , top+  , bottom+  , dig+  , digBottom+  , push+  , pushBottom+  ) where++import qualified Data.Foldable as Foldable+import Data.List (genericDrop, intercalate)+import Data.Sequence+import qualified Data.Sequence as Sequence++import Text.PrettyShow++-----------------------------------------------------------++newtype Deque a = D (Seq a)+  deriving (Show, Eq, Ord)++instance (PrettyShow a) => PrettyShow (Deque a) where+  pshow (D s) = Prelude.concat [ []+    , "["+    , intercalate "," . map pshow $ Foldable.toList s+    , "..]"+    ]++-----------------------------------------------------------++mkDeque :: Deque a+mkDeque = D empty++mkDeque1 :: a -> Deque a+mkDeque1 = D . singleton++isEmpty :: Deque a -> Bool+isEmpty (D s) = Sequence.null s++depth :: Deque a -> Integer+depth (D s) = Foldable.foldl' (\l _ -> 1 + l) 0 s++toList :: Deque a -> [a]+toList (D s) = Foldable.toList s++pop :: Deque a -> Deque a+pop (D s) = case viewl s of+  _ :< s' -> D s'+  EmptyL -> D empty++popBottom :: Deque a -> Deque a+popBottom (D s) = case viewr s of+  s' :> _ -> D s'+  EmptyR -> D empty++top :: Deque a -> Maybe a+top (D s) = case viewl s of+  x :< _ -> Just x+  EmptyL -> Nothing++bottom :: Deque a -> Maybe a+bottom (D s) = case viewr s of+  _ :> x -> Just x+  EmptyR -> Nothing++dig :: (Integral i) => i -> Deque a -> Maybe a+dig n = top . head . genericDrop n . iterate pop++digBottom :: (Integral i) => i -> Deque a -> Maybe a+digBottom n = top . head . genericDrop n . iterate popBottom++push :: a -> Deque a -> Deque a+push x (D s) = D (x <| s)++pushBottom :: a -> Deque a -> Deque a+pushBottom x (D s) = D (s |> x)++
+ src/Data/History.hs view
@@ -0,0 +1,101 @@+module Data.History (+    History (getSize)+  , empty+  , fromHistory+  , fromList+  , toList+  , push+  , pop+  , popN+  , lookup+  ) where++import Prelude hiding (lookup)++import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.Maybe (fromMaybe, mapMaybe)++import Text.PrettyShow++-----------------------------------------------------------++data History a = History {+    getSize :: Int+  , getReplacePos :: Int+  , getMap :: IntMap a+  }+  deriving+    (Show)++instance (PrettyShow a) => PrettyShow (History a) where+  pshow = ("History " ++) . pshow . toList++empty :: Int -> History a+empty n = fromList (Just n) []++fromHistory :: Maybe Int -> History a -> History a+fromHistory Nothing h = h+fromHistory (Just newSize) h+  | newSize >= getSize h = h { getSize = newSize }+  | otherwise = fromList (Just newSize) $ take newSize $ toList h -- TODO : Make this more efficient if needed++fromList :: Maybe Int -> [a] -> History a+fromList mSize xs = foldr push History { +    getSize = size+  , getReplacePos = 0+  , getMap = IntMap.empty+  } xs+  where+    size = fromMaybe (length xs) mSize++getHeadPos :: History a -> Int+getHeadPos h = if rpos - 1 < 0+  then getSize h - 1+  else rpos - 1+  where+    rpos = getReplacePos h++fromLogicalPos :: History a -> Int -> Int+fromLogicalPos h pos = if pos <= hpos+  then hpos - pos+  else size + hpos - pos+  where+    size = getSize h+    hpos = getHeadPos h++push :: a -> History a -> History a+push x h = h {+    getMap = IntMap.insert rpos x $ getMap h+  , getReplacePos = if rpos + 1 < getSize h+      then rpos + 1+      else 0+  }+  where+    rpos = getReplacePos h++pop :: History a -> History a+pop h = h {+    getMap = IntMap.delete (getHeadPos h) $ getMap h+  , getReplacePos = if rpos - 1 < 0+      then getSize h - 1+      else rpos - 1+  }+  where+    rpos = getReplacePos h++popN :: Int -> History a -> History a+popN n = head . drop n . iterate pop++lookup :: Int -> History a -> Maybe a+lookup pos h+  | 0 <= pos && pos < size = IntMap.lookup (fromLogicalPos h pos) $ getMap h+  | otherwise = Nothing+  where+    size = getSize h++toList :: History a -> [a]+toList h = mapMaybe (`lookup` h) [0 .. getSize h - 1]+++
+ src/Data/I.hs view
@@ -0,0 +1,26 @@+module Data.I (+    I+  ) where++import Data.Bits+import Data.ByteSize+import Data.Int+import Data.IntegralLike+import Data.MaybeBounded++import Text.PrettyShow++import Random++-----------------------------------------------------------++-- The I type class is intentionally empty. Used to clump the type classes.+class (Show i, Bits i, ByteSize i, Integral i, IntegralLike i, MaybeBounded i, PrettyShow i, Random i, Read i) => I i where++instance I Integer where+instance I Int where+instance I Int8 where+instance I Int16 where+instance I Int32 where+instance I Int64 where+
+ src/Data/IntegralLike.hs view
@@ -0,0 +1,37 @@+module Data.IntegralLike (+    IntegralLike (..)+  ) where++import Data.Char (ord)+import Data.Int++-----------------------------------------------------------++class IntegralLike a where+  asIntegral :: (Integral i) => a -> i++instance IntegralLike Bool where+  asIntegral False = 0+  asIntegral True = 1++instance IntegralLike Char where+  asIntegral = fromIntegral . ord++instance IntegralLike Integer where+  asIntegral = fromInteger++instance IntegralLike Int where+  asIntegral = fromIntegral++instance IntegralLike Int8 where+  asIntegral = fromIntegral++instance IntegralLike Int16 where+  asIntegral = fromIntegral++instance IntegralLike Int32 where+  asIntegral = fromIntegral++instance IntegralLike Int64 where+  asIntegral = fromIntegral+
+ src/Data/Labeled.hs view
@@ -0,0 +1,19 @@+module Data.Labeled (+    Labeled (getLabel, unlabel)+  , label+  ) where++-----------------------------------------------------------++data Labeled l a = Labeled {+    getLabel :: l+  , unlabel :: a+  }+  deriving (Show)++label :: l -> a -> Labeled l a+label = Labeled++instance Functor (Labeled l) where+  fmap f l = l { unlabel = f $ unlabel l }+
+ src/Data/LogicalBits.hs view
@@ -0,0 +1,23 @@+module Data.LogicalBits (+    logicalBit+  , testLogicalBit+  ) where++import Prelude hiding (fromInteger, toInteger)++import Data.Bits++-----------------------------------------------------------++toInt :: (Integral a) => a -> Int+toInt = fromIntegral++fromInt :: (Integral a) => Int -> a+fromInt = fromIntegral++logicalBit :: (Bits a, Integral a) => Int -> a+logicalBit = fromInt . bit++testLogicalBit :: (Bits a, Integral a) => a -> Int -> Bool+testLogicalBit n = testBit $ toInt n+
+ src/Data/MaybeBounded.hs view
@@ -0,0 +1,36 @@+module Data.MaybeBounded (+    MaybeBounded (..)+  ) where++import Data.Int++-----------------------------------------------------------++class MaybeBounded a where+  maybeMaxBound :: Maybe a+  maybeMinBound :: Maybe a++instance MaybeBounded Integer where+  maybeMaxBound = Nothing+  maybeMinBound = Nothing++instance MaybeBounded Int where+  maybeMaxBound = Just maxBound+  maybeMinBound = Just minBound++instance MaybeBounded Int8 where+  maybeMaxBound = Just maxBound+  maybeMinBound = Just minBound++instance MaybeBounded Int16 where+  maybeMaxBound = Just maxBound+  maybeMinBound = Just minBound++instance MaybeBounded Int32 where+  maybeMaxBound = Just maxBound+  maybeMinBound = Just minBound++instance MaybeBounded Int64 where+  maybeMaxBound = Just maxBound+  maybeMinBound = Just minBound+
+ src/Data/Stack.hs view
@@ -0,0 +1,63 @@+module Data.Stack (+    Stack+  , mkStack+  , mkStack1+  , isEmpty+  , depth+  , toList+  , pop+  , top+  , dig+  , push+  ) where++import Data.List (genericDrop, genericLength, intercalate)++import Text.PrettyShow++-----------------------------------------------------------++newtype Stack a = S [a]+  deriving (Show, Eq, Ord)++instance (PrettyShow a) => PrettyShow (Stack a) where+  pshow (S xs) = concat [ []+    , "["+    , intercalate "," . map pshow $ xs+    , "..]"+    ]++-----------------------------------------------------------++mkStack :: Stack a+mkStack = S []++mkStack1 :: a -> Stack a+mkStack1 x = S [x]++isEmpty :: Stack a -> Bool+isEmpty (S []) = True+isEmpty _      = False++depth :: Stack a -> Integer+depth (S xs) = genericLength xs++toList :: Stack a -> [a]+toList (S xs) = xs++pop :: Stack a -> Stack a+pop (S xs) = case xs of+  _ : ys -> S ys+  [] -> S []++top :: Stack a -> Maybe a+top (S xs) = case xs of+  y : _ -> Just y+  [] -> Nothing++dig :: (Integral i) => i -> Stack a -> Maybe a+dig n = top . head . genericDrop n . iterate pop++push :: a -> Stack a -> Stack a+push x (S xs) = S (x : xs)+
+ src/Data/StackSet.hs view
@@ -0,0 +1,59 @@+module Data.StackSet (+    StackSet+  , empty+  , toList+  , insert+  , delete+  , member+  ) where++import Data.Labeled+import Data.List (sortBy)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Ord (comparing)++-----------------------------------------------------------++newtype Tagged l a = T { untag :: Labeled l a }++instance (Eq a) => Eq (Tagged l a) where+  T l1 == T l2 = unlabel l1 == unlabel l2++instance (Ord a) => Ord (Tagged l a) where+  compare (T l1) (T l2) = comparing unlabel l1 l2++type Tag = Int++data StackSet a = S !Tag (Set (Tagged Tag a))++empty :: StackSet a+empty = S maxBound Set.empty++toList :: StackSet a -> [a]+toList (S _ set) = map (unlabel . untag) $ sortBy (comparing $ getLabel . untag) $ Set.toList set++insert :: (Ord a) => a -> StackSet a -> StackSet a+insert x stackSet@(S n _) = if n > minBound+  then insert' x stackSet'+  else insert' x $ retag stackSet'+  where+    stackSet' = delete x stackSet++insert' :: (Ord a) => a -> StackSet a -> StackSet a+insert' x (S n set) = if n > minBound+  then S (n - 1) $ Set.insert (T $ label n x) set+  else error "StackSet.insert: Too many elements in stackset!"++retag :: (Ord a) => StackSet a -> StackSet a+retag = foldr insert' empty . toList++dummyTag :: a -> Tagged Tag a+dummyTag x = T $ label undefined x++delete :: (Ord a) => a -> StackSet a -> StackSet a+delete x (S n set) = S n $ Set.delete (dummyTag x) set++member :: (Ord a) => a -> StackSet a -> Bool+member x (S _ set) = Set.member (dummyTag x) set+
+ src/Data/Tuple/Map.hs view
@@ -0,0 +1,16 @@+module Data.Tuple.Map (+    map1+  , map2+  ) where++import Data.Tuple.Select+import Data.Tuple.Update++-----------------------------------------------------------++map1 :: (Sel1 a1 a, Upd1 b a1 c) => (a -> b) -> a1 -> c+map1 f t = upd1 (f $ sel1 t) t++map2 :: (Sel2 a1 a, Upd2 b a1 c) => (a -> b) -> a1 -> c+map2 f t = upd2 (f $ sel2 t) t+
+ src/Data/Vector.hs view
@@ -0,0 +1,75 @@+module Data.Vector (+    Vector+  , unVector+  , mkVector+  , takeV+  , dropV+  , reverseV+  , zipWithV+  , foldrV+  , cons+  , append+  , liftOrd+  ) where++import Data.List (intercalate)++import Text.PrettyShow++-----------------------------------------------------------++newtype Vector a = Vector { unVector :: [a] }+  deriving (Show, Eq)++instance (PrettyShow a) => PrettyShow (Vector a) where+  pshow (Vector xs) = '(' : intercalate "," (map pshow xs) ++ ")"++instance Functor Vector where+  fmap f = Vector . map f . unVector++instance (Num a) => Num (Vector a) where+  fromInteger = Vector . repeat . fromInteger+  negate = fmap negate+  signum = fmap signum+  abs = fmap abs+  (+) = zipWithV' (+)+  (-) = zipWithV' (-)+  (*) = zipWithV' (*)++mkVector :: [a] -> Vector a+mkVector = Vector++liftOrd :: (a -> a -> Bool) -> (Vector a -> Vector a -> Bool)+liftOrd f xs = and . unVector . zipWithV f xs++dropV :: Int -> Vector a -> Vector a+dropV n = mkVector . drop n . unVector++takeV :: Int -> Vector a -> Vector a+takeV n = mkVector . take n . unVector++reverseV :: Vector a -> Vector a+reverseV = mkVector . reverse . unVector++zipWithV :: (a -> b -> c) -> Vector a -> Vector b -> Vector c+zipWithV f (Vector xs) (Vector ys) = Vector $ zipWith f xs ys++zipWithV' :: (Num a, Num b) => (a -> b -> c) -> Vector a -> Vector b -> Vector c+zipWithV' f (Vector xs) (Vector ys) = Vector $ zipWith' f xs ys++zipWith' :: (Num a, Num b) => (a -> b -> c) -> [a] -> [b] -> [c]+zipWith' _ [] [] = []+zipWith' f (x:xs) [] = f x 0 : zipWith' f xs []+zipWith' f [] (y:ys) = f 0 y : zipWith' f [] ys+zipWith' f (x:xs) (y:ys) = f x y : zipWith' f xs ys++foldrV :: (a -> b -> b) -> b -> Vector a -> b+foldrV f z = foldr f z . unVector++infixr 5 `cons`, `append`+cons :: a -> Vector a -> Vector a+x `cons` (Vector xs) = Vector (x : xs)++append :: Vector a -> Vector a -> Vector a+append xs ys = foldrV cons ys xs+
+ src/Debug/Debug.hs view
@@ -0,0 +1,377 @@+module Debug.Debug (+    runDebugger+  ) where++import Control.Monad.State.Strict++import Data.Char (ord)+import qualified Data.Deque as Deque+import qualified Data.History as History+import Data.List (intercalate, genericReplicate, stripPrefix, isPrefixOf, genericTake)+import Data.Maybe (fromMaybe)+import qualified Data.Set as Set+import Data.Vector++import Debug.Debugger hiding (runDebugger)++import Space.Cell+import Space.Space++import System.Exit (exitSuccess)+import System.IO (stdin, stdout, hFlush, hGetLine)+import System.IO.Buffering (withBuffering, BufferMode (..))++import Text.Help.Debug (help)+import Text.PrettyShow++import Env+import Instruction+import Ip++-----------------------------------------------------------++updateHistory :: (I i) => Env i -> Env i+updateHistory env = withHistory' (History.push envNoHist) env+  where+    withHistory' = withDebugger . withHistory+    envNoHist = withHistory' (const $ History.empty 0) env++runDebugger :: (I i) => Instruction i ()+runDebugger = runDebugger' >> modify updateHistory++runDebugger' :: (I i) => Instruction i ()+runDebugger' = do+  env <- get+  let dim = getDim env+      toss = currentToss env+      debugger = getDebugger env+      breakPoints = getBreakPoints debugger+      watchExprs = getWatchExprs debugger+      currPos = getPos $ currentIp env+  case getDebugMode debugger of+    DebugOff -> return ()+    DebugContinue+      | genericTake dim (unVector currPos) `Set.member` breakPoints -> stepDebug >> go+      | any (`isPrefixOf` Deque.toList toss) $ Set.toList watchExprs -> stepDebug >> go+      | otherwise -> return ()+    DebugStep -> go+  where+    go :: (I i) => Instruction i ()+    go = do+      liftIO $ putChar '\n'+      cellDebug+      ipDebug+      sDebug+      gets (getLocaleRads . getDebugger) >>= localeDebug . Just . mapPair fromIntegral+      fetchDebugCommand++fetchDebugCommand :: (I i) => Instruction i ()+fetchDebugCommand = do+  cmd <- liftIO $ do+    putStr "> "+    hFlush stdout+    withBuffering LineBuffering stdin hGetLine+  case delimWords "'\"" cmd of+    Nothing -> do+      liftIO $ putStrLn $ "Unknown command: " ++ cmd+      fetchDebugCommand+    Just cmd' -> case mapHead (dropWhile (== '-')) cmd' of+      [] -> return ()+      "?" : []+        -> helpDebug >> fetchDebugCommand+      "back" : []+        -> backDebug "1"+      "back" : arg : []+        -> backDebug arg+      "break" : args+        -> breakDebug args >> fetchDebugCommand+      "breaks" : []+        -> breaksDebug >> fetchDebugCommand+      "cell" : []+        -> cellDebug >> fetchDebugCommand+      "cellat" : args+        -> cellatDebug args >> fetchDebugCommand+      "clear" : args+        -> clearDebug args >> fetchDebugCommand+      "continue" : []+        -> continueDebug+      "dim" : []+        -> dimDebug >> fetchDebugCommand+      "exit" : []+        -> quitDebug+      "help" : []+        -> helpDebug >> fetchDebugCommand+      "ip" : []+        -> ipDebug >> fetchDebugCommand+      "locale" : []+        -> localeDebug Nothing >> fetchDebugCommand+      "locale" : rad : []+        -> localeDebug (fmap duplicate $ tryRead rad) >> fetchDebugCommand+      "locale" : xrad : yrad : []+        -> localeDebug (liftM2 (,) (tryRead xrad) (tryRead yrad)) >> fetchDebugCommand+      "nodebug" : []+        -> nodebugDebug+      "pop" : arg : []+        -> popDebug arg >> fetchDebugCommand+      "push" : args+        -> pushDebug args >> fetchDebugCommand+      "quit" : []+        -> quitDebug+      "record" : arg : []+        -> recordDebug arg >> fetchDebugCommand+      "setpos" : args+        -> setposDebug args >> fetchDebugCommand+      "space" : []+        -> spaceDebug >> fetchDebugCommand+      "s" : []+        -> sDebug >> fetchDebugCommand+      "setlocale" : xrad : yrad : []+        -> setlocaleDebug xrad yrad >> fetchDebugCommand+      "ss" : []+        -> ssDebug >> fetchDebugCommand+      "step" : []+        -> stepDebug >> fetchDebugCommand+      "unshowable" : arg : []+        -> unshowableDebug arg >> fetchDebugCommand+      "unwatch" : args+        -> unwatchDebug args >> fetchDebugCommand+      "watch" : args+        -> watchDebug args >> fetchDebugCommand+      "watches" : []+        -> watchesDebug >> fetchDebugCommand+      _ +        -> liftIO (putStrLn $ "Unknown command: " ++ cmd) >> fetchDebugCommand++mapPair :: (a -> b) -> (a, a) -> (b, b)+mapPair f (x, y) = (f x, f y)++duplicate :: a -> (a, a)+duplicate x = (x, x)++mapHead :: (a -> a) -> [a] -> [a]+mapHead _ [] = []+mapHead f (x:xs) = f x : xs++delimWords :: String -> String -> Maybe [String]+delimWords delims str = fmap (reverse . dropWhile (== "") . reverse) $ delimWords' delims str++delimWords' :: String -> String -> Maybe [String]+delimWords' _ "" = Just [""]+delimWords' delims (c:cs)+  | c == ' ' = fmap ("" :) $ delimWords' delims $ dropWhile (== ' ') cs+  | c `elem` delims = fmap (mapHead (\str -> c : takeWhile (/= c) cs ++ str ++ [c])) $ delimWords'' c cs+  | otherwise = fmap (mapHead (c:)) $ delimWords' delims cs+  where+    delimWords'' currDelim = delimWords' delims <=< stripPrefix [currDelim] . dropWhile (/= currDelim)++-----------------------------------------------------------++readVector :: (I i) => [String] -> Maybe (Vector i)+readVector [] = Nothing+readVector strs = case tryReadList strs of+  Nothing -> Nothing+  Just ns -> Just $ mkVector $ ns ++ repeat 0++tryRead :: (Read a) => String -> Maybe a+tryRead str = case reads str of+  [(x, "")] -> Just x+  _ -> Nothing++tryReadList :: (Read a) => [String] -> Maybe [a]+tryReadList [] = Just []+tryReadList (str:strs) = tryRead str >>= \x -> fmap (x :) $ tryReadList strs++readCells :: (I i) => [String] -> [Maybe i]+readCells [] = []+readCells (str:strs) = case str of+  '\'' : str' -> readString '\'' str'+  '"'  : str' -> readString '"'  str'+  "" -> readCells strs+  _ -> case tryRead str of+    Just n -> Just n : readCells strs+    Nothing -> case str of+      [c] -> (Just . fromIntegral . ord) c : readCells strs+      _ -> Nothing : readCells strs+  where+    readString quote s = case sequence (readString' quote s) of+      Nothing -> Nothing : readCells strs+      Just cells -> cells ++ readCells strs+    --+    readString' _ "" = [Nothing]+    readString' quote (c:cs)+      | c == quote = case cs of+        "" -> []+        _ -> [Nothing]+      | otherwise = (Just . Just . fromIntegral . ord) c : readString' quote cs+    +-----------------------------------------------------------++invalidVector :: Instruction i ()+invalidVector = liftIO $ putStrLn "Invalid vector."++invalidArgument :: Instruction i ()+invalidArgument = liftIO $ putStrLn "Invalid argument."++-----------------------------------------------------------++backDebug :: (I i) => String -> Instruction i ()+backDebug arg = case tryRead arg of +  Nothing -> invalidArgument+  Just n -> if n <= 0+    then invalidArgument >> fetchDebugCommand+    else do+      hist <- gets $ getHistory . getDebugger+      case History.lookup (n - 1) hist of+        Nothing -> do+          liftIO $ putStrLn "Not enough history. Try again."+          fetchDebugCommand+        Just env' -> do+          let hist' = History.popN n hist+          put env'+          modify $ withDebugger $ \d -> d { getDebugMode = DebugStep, getHistory = hist' }+          runDebugger'++breakDebug :: (I i) => [String] -> Instruction i ()+breakDebug args = case readVector args of+  Nothing -> invalidVector+  Just pos -> modify $ addBreakPoint $ unVector pos++breaksDebug :: (I i) => Instruction i ()+breaksDebug = do+  breakPoints <- gets $ Set.toList . getBreakPoints . getDebugger+  liftIO $ mapM_ pprint breakPoints++cellDebug :: (I i) => Instruction i ()+cellDebug = gets currentCell >>= liftIO . pprint++cellatDebug :: (I i) => [String] -> Instruction i ()+cellatDebug args = case readVector args of+  Nothing -> invalidVector+  Just pos -> do+    dim <- gets getDim+    gets getSpace >>= liftIO . pprint . flip cellAt (takeV dim $ pos `append` 0)++clearDebug :: (I i) => [String] -> Instruction i ()+clearDebug args+  | args == ["*"] = modify $ withDebugger $ withBreakPoints $ const Set.empty+  | otherwise = case readVector args of+      Nothing -> invalidVector+      Just pos -> modify $ removeBreakPoint $ unVector pos++continueDebug :: (I i) => Instruction i ()+continueDebug = modify $ withDebugger $ \d -> d { getDebugMode = DebugContinue }++dimDebug :: (I i) => Instruction i ()+dimDebug = gets getDim >>= liftIO . pprint ++helpDebug :: Instruction i ()+helpDebug = liftIO help++ipDebug :: (I i) => Instruction i ()+ipDebug = gets currentIp >>= liftIO . pprint++localeDebug :: (I i) => Maybe (Int, Int) -> Instruction i ()+localeDebug mrads = do+  env <- get+  let unshowableCellChar = getUnshowableChar env+      dim = getDim env+      s = getSpace env+      pos = getPos . currentIp $ env+      defaultRads = getLocaleRads $ getDebugger env+      (xrad, yrad) = mapPair (fromIntegral . min 666 . max 1) $ fromMaybe defaultRads mrads+      top = "+" ++ rep xrad '-' ++ "v" ++ rep xrad '-' ++ "+"+      bot = "+" ++ rep xrad '-' ++ "^" ++ rep xrad '-' ++ "+"+      topRows = intercalate "\n" ["|" ++ chars2 [[x, y] | x <- [-xrad .. xrad]] ++ "|" | y <- [-yrad .. -1]]+      midRow  = ">" ++ chars1 [[x, 0] | x <- [-xrad .. xrad]] ++ "<"+      botRows = intercalate "\n" ["|" ++ chars2 [[x, y] | x <- [-xrad .. xrad]] ++ "|" | y <- [1 .. yrad]]+      str = unlines [top, topRows, midRow, botRows, bot]+      disp xs = takeV dim $ pos + mkVector xs+      chars1 = map (showCell . cellAt s . disp)+      chars2 = if dim >= 2+        then chars1+        else const . rep (2 * xrad + 1) $ ' '+      showCell = fromMaybe unshowableCellChar . cellToPrintableChar+  liftIO $ putStrLn str+  where+    rep = genericReplicate++nodebugDebug :: (I i) => Instruction i ()+nodebugDebug = modify $ withDebugger $ \d -> d { getDebugMode = DebugOff }++popDebug :: (I i) => String -> Instruction i ()+popDebug arg = case tryRead arg :: Maybe Integer of+  Nothing -> invalidArgument+  Just n -> popNInstr_ n++pushDebug :: (I i) => [String] -> Instruction i ()+pushDebug args = case sequence $ readCells args of+  Nothing -> invalidArgument+  Just cells -> pushVectorInstr $ mkVector $ reverse cells++quitDebug :: (I i) => Instruction i ()+quitDebug = liftIO exitSuccess++recordDebug :: (I i) => String -> Instruction i ()+recordDebug arg = case tryRead arg of+  Nothing -> invalidArgument+  Just n -> modify $ withDebugger $ withHistory $ History.fromHistory $ Just n++setposDebug :: (I i) => [String] -> Instruction i ()+setposDebug args = case readVector args of+  Nothing -> invalidVector+  Just pos -> setPosInstr pos++spaceDebug :: (I i) => Instruction i ()+spaceDebug = gets getSpace >>= liftIO . pprint++sDebug :: (I i) => Instruction i ()+sDebug = do+  toss <- gets currentToss+  let ptInt = pshow toss+      ptGuts = id +        . words +        . map (\c -> if c == ',' then ' ' else c) +        . reverse +        . drop 3 +        . reverse +        . drop 1 +        $ ptInt+      ptChar = "[" ++ intercalate "," (map (showChr . read) ptGuts) ++ "..]"+  liftIO $ putStrLn ptChar >> putStrLn ptInt+  where+    showChr :: Integer -> String+    showChr n = maybe "\\???" show $ cellToChar $ chrCell n++setlocaleDebug :: (I i) => String -> String -> Instruction i ()+setlocaleDebug xrad yrad = case tryRead xrad of+  Nothing -> invalidArgument+  Just xrad' -> case tryRead yrad of+    Nothing -> invalidArgument+    Just yrad' -> modify $ withDebugger $ \d -> d {+        getLocaleRads = (xrad', yrad')+      }++ssDebug :: (I i) => Instruction i ()+ssDebug = gets currentSs >>= liftIO . pprint ++stepDebug :: (I i) => Instruction i ()+stepDebug = modify $ withDebugger $ \d -> d { getDebugMode = DebugStep }++unshowableDebug :: (I i) => String -> Instruction i ()+unshowableDebug str = case str of +  [c] -> modify $ \env -> env { getUnshowableChar = c }+  _ -> invalidArgument++unwatchDebug :: (I i) => [String] -> Instruction i ()+unwatchDebug args = case sequence $ readCells args of +  Nothing -> invalidArgument+  Just cells -> modify $ withDebugger $ withWatchExprs $ Set.delete cells++watchDebug :: (I i) => [String] -> Instruction i ()+watchDebug args = case sequence $ readCells args of +  Nothing -> invalidArgument+  Just cells -> modify $ withDebugger $ withWatchExprs $ Set.insert cells++watchesDebug :: (I i) => Instruction i ()+watchesDebug = gets (Set.toList . getWatchExprs . getDebugger) >>= liftIO . mapM_ pprint+
+ src/Debug/Debugger.hs view
@@ -0,0 +1,40 @@+module Debug.Debugger (+    Debugger (..)+  , DebugMode (..)+  , withBreakPoints+  , withWatchExprs+  , withHistory+  ) where++import Control.Monad.State.Strict++import Data.History+import Data.Set (Set)++-----------------------------------------------------------++type Instruction env i = StateT (env i) IO++-----------------------------------------------------------++data DebugMode = DebugStep | DebugContinue | DebugOff+  deriving (Show, Eq, Ord)++data Debugger env i = Debugger {+    getDebugMode :: DebugMode+  , runDebugger :: Instruction env i ()+  , getBreakPoints :: Set [i]+  , getWatchExprs :: Set [i]+  , getHistory :: !(History (env i))+  , getLocaleRads :: (Int, Int)+  }++withBreakPoints :: (Set [i] -> Set [i]) -> Debugger env i -> Debugger env i+withBreakPoints f d = d { getBreakPoints = f $ getBreakPoints d }++withWatchExprs :: (Set [i] -> Set [i]) -> Debugger env i -> Debugger env i+withWatchExprs f d = d { getWatchExprs = f $ getWatchExprs d }++withHistory :: (History (env i) -> History (env i)) -> Debugger env i -> Debugger env i+withHistory f d = d { getHistory = f $ getHistory d } +
+ src/Env.hs view
@@ -0,0 +1,155 @@+module Env (+    Env (..)+  , mkEnv+  , withDebugger+  , withIp+  , withIps+  , withSpace+  , withSs+  , withToss+  , withSemantics+  , currentCell+  , currentIp+  , currentSs+  , currentToss+  , addSpawnedIp+  , addBreakPoint+  , removeBreakPoint+  ) where++import Control.Monad.State.Strict++import Data.Deque+import Data.I+import Data.List (genericTake)+import Data.List.Zipper (Zipper)+import qualified Data.List.Zipper as Zipper+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Data.MaybeBounded+import qualified Data.Set as Set+import Data.Stack+import qualified Data.Stack as Stack+import Data.Vector++import Debug.Debugger++import Space.Cell+import Space.Space++import Ip+import Semantics+import UnknownInstruction+++-----------------------------------------------------------++type Instruction i = StateT (Env i) IO++type Fingerprints i = Map Integer [(i, Instruction i ())]++data Env i = Env {+    getIps :: Zipper (Ip Env i)+  , getDebugger :: Debugger Env i+  , getDim :: Int+  , getSpace :: Space i+  , getSpawnedIps :: [Ip Env i]+  , getValidIds :: [i]+  , getUnshowableChar :: Char+  , getUnknownMode :: UnknownInstruction+  , getProgName :: String+  , getFungeArgs :: [String]+  , getFingerprints :: Fingerprints i+  , getValidReferences :: [i]+  , getReferenceMap :: Map i (Vector i)+  }++mkEnv :: (I i) => Int+        -> Space i +        -> UnknownInstruction +        -> Debugger Env i +        -> String +        -> [String] +        -> Fingerprints i +        -> Map i (Instruction i ())+        -> Env i+mkEnv dim space unknownMode debugger progName args fingerprints baseSemantics = Env {+    getIps = Zipper.fromList [mkIp dim ident baseSemantics]+  , getDebugger = debugger+  , getDim = dim+  , getSpace = space+  , getSpawnedIps = []+  , getValidIds = idents+  , getUnshowableChar = '®'+  , getUnknownMode = unknownMode+  , getProgName = progName+  , getFungeArgs = args+  , getFingerprints = fingerprints+  , getValidReferences = uniqueVals+  , getReferenceMap = Map.empty+  }+  where+    ident : idents = uniqueVals++uniqueVals :: (I i) => [i]+uniqueVals = case maybeMaxBound of+  Nothing -> [0 ..]+  Just maxN -> [0 .. maxN] ++ case maybeMinBound of +    Nothing -> iterate (subtract 1) (-1)+    Just minN -> init [minN .. 0]++currentIp :: Env i -> Ip Env i+currentIp = Zipper.cursor . getIps++setCurrentIp :: Ip Env i -> Env i -> Env i+setCurrentIp ip = withIps $ Zipper.replace ip++withDebugger :: (Debugger Env i -> Debugger Env i) -> Env i -> Env i+withDebugger f env = env { getDebugger = f $ getDebugger env }++withIp :: (Ip Env i -> Ip Env i) -> Env i -> Env i+withIp f env = setCurrentIp (f $ currentIp env) env++withIps :: (Zipper (Ip Env i) -> Zipper (Ip Env i)) -> Env i -> Env i+withIps f env = env { getIps = f $ getIps env }++withSemantics :: (Semantics Env i -> Semantics Env i) -> Env i -> Env i+withSemantics f = withIp $ \ip -> ip { getSemantics = f $ getSemantics ip }++withSpace :: (Space i -> Space i) -> Env i -> Env i+withSpace f env = env { getSpace = f $ getSpace env }++withSs :: (Stack (Deque i) -> Stack (Deque i)) -> Env i -> Env i+withSs f = withIp $ \ip -> ip { getSs = f $ getSs ip }++withToss :: (Deque i -> Deque i) -> Env i -> Env i+withToss f = withSs $ \ss -> case Stack.top ss of+  Just s -> Stack.push (f s) $ Stack.pop ss+  Nothing -> mkStack1 $ f mkDeque++currentSs :: Env i -> Stack (Deque i)+currentSs = getSs . currentIp++currentToss :: Env i -> Deque i+currentToss = fromMaybe mkDeque . Stack.top . currentSs++currentCell :: (Integral i) => Env i -> Cell i+currentCell env = cellAt s pos+  where+    s = getSpace env+    pos = getPos . currentIp $ env++addSpawnedIp :: Ip Env i -> Env i -> Env i+addSpawnedIp ip env = env { getSpawnedIps = ip : getSpawnedIps env }++addBreakPoint :: (I i) => [i] -> Env i -> Env i+addBreakPoint pos env = withDebugger (withBreakPoints $ Set.insert pos') env+  where+    pos' = genericTake (getDim env) $ pos ++ repeat 0++removeBreakPoint :: (I i) => [i] -> Env i -> Env i+removeBreakPoint pos env = withDebugger (withBreakPoints $ Set.delete pos') env+  where+    pos' = genericTake (getDim env) $ pos ++ repeat 0+
+ src/Fingerprint.hs view
@@ -0,0 +1,62 @@+module Fingerprint (+    Fingerprints+  , fingerprints+  ) where++import Data.Char (ord)+import Data.IntegralLike+import Data.List (foldl')+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Tuple.Map++import Instruction++import qualified Fingerprint.BASE as BASE+import qualified Fingerprint.BF93 as BF93+import qualified Fingerprint.BOOL as BOOL+import qualified Fingerprint.BZRO as BZRO+import qualified Fingerprint.CPLI as CPLI+import qualified Fingerprint.FIXP as FIXP+import qualified Fingerprint.HRTI as HRTI+import qualified Fingerprint.MODE as MODE+import qualified Fingerprint.MODU as MODU+import qualified Fingerprint.NOP  as NOP+import qualified Fingerprint.NULL as NULL+import qualified Fingerprint.ORTH as ORTH+import qualified Fingerprint.RECD as RECD+import qualified Fingerprint.REFC as REFC+import qualified Fingerprint.ROMA as ROMA+import qualified Fingerprint.STRN as STRN++-----------------------------------------------------------++type Fingerprints i = Map Integer [(i, Instruction i ())]++asId :: String -> Integer+asId = fromIntegral . foldl' (\fId x -> fId * 256 + x) 0 . map ord++fingerprints :: (I i) => Fingerprints i+fingerprints = foldr (uncurry (insert . asId) . map2 (map $ map1 asIntegral)) Map.empty [+    (BASE.name, BASE.semantics)+  , (BF93.name, BF93.semantics)+  , (BOOL.name, BOOL.semantics)+  , (BZRO.name, BZRO.semantics)+  , (CPLI.name, CPLI.semantics)+  , (FIXP.name, FIXP.semantics)+  , (HRTI.name, HRTI.semantics)+  , (MODE.name, MODE.semantics)+  , (MODU.name, MODU.semantics)+  , (NOP.name,  NOP.semantics )+  , (NULL.name, NULL.semantics)+  , (ORTH.name, ORTH.semantics)+  , (RECD.name, RECD.semantics)+  , (REFC.name, REFC.semantics)+  , (ROMA.name, ROMA.semantics)+  , (STRN.name, STRN.semantics)+  ]+  where+    insert k v m = if Map.member k m+      then error $ "Fingerprint.fingerprints: Duplicate entry for fingerprint " ++ show k+      else Map.insert k v m+
+ src/Fingerprint/BASE.hs view
@@ -0,0 +1,93 @@+module Fingerprint.BASE (+    name+  , semantics+  ) where++import Control.Monad.State.Strict++import Data.Char (chr, ord, toLower)+import Data.Maybe (isNothing)+import Data.MaybeBounded++import Numeric (showIntAtBase)++import System.IO (stdin, stdout, hFlush)+import System.IO.Buffering (BufferMode (..), withBuffering)++import Instruction++-----------------------------------------------------------++name :: String+name = "BASE"++semantics :: (I i) => [(Char, Instruction i ())]+semantics = [+    ('B', outputBaseInstr 2)+  , ('H', outputBaseInstr 16)+  , ('I', inputBaseInstr)+  , ('N', popInstr >>= outputBaseInstr)+  , ('O', outputBaseInstr 8)+  ]++intToDigit :: Int -> Char+intToDigit i+  | 0 <= i && i <= 9 = chr $ ord '0' + i+  | otherwise = chr $ ord 'a' - 10 + i++outputBaseInstr :: (I i) => i -> Instruction i ()+outputBaseInstr base+  | 2 <= base && base <= 36 = do+      n <- popInstr+      outcome <- tryLiftIO $ do+        when (n < 0) $ putChar '-'+        putStr $ showIntAtBase base intToDigit (abs n) " "+      when (isNothing outcome) reverseInstr+  | otherwise = popInstr >> reverseInstr++inputBaseInstr :: (I i) => Instruction i ()+inputBaseInstr = do+  base <- popInstr+  if 2 <= base && base <= 36+    then do+      outcome <- tryLiftIO $ do+        hFlush stdout+        withBuffering NoBuffering stdin $ const $ getBase base+      maybe reverseInstr pushInstr outcome+    else reverseInstr  ++toBase :: (Integral i) => i -> Char -> Maybe Integer+toBase base c+  | '0' <= c && c <= '9' = checkSize $ fromIntegral $ ord c - ord '0'+  | 'a' <= c' && c' <= 'z' = checkSize $ fromIntegral $ ord c' + 10 - ord 'a'+  | otherwise = Nothing+  where+    c' = toLower c+    checkSize n = if n < fromIntegral base+      then Just n+      else Nothing++getBase :: (I i) => i -> IO i+getBase base = do+  c <- getChar+  case toBase base c of+    Just k -> case maybeMaxBound `asTypeOf` Just base of+      Just bound -> if k > fromIntegral bound+        then getBase base+        else getBase' base k+      Nothing -> getBase' base k+    Nothing -> getBase base++getBase' :: (I i) => i -> Integer -> IO i+getBase' base n = do+  c <- getChar+  case toBase base c of+    Just k -> let+      n' = fromIntegral base * n + k+      in case maybeMaxBound `asTypeOf` Just base of+        Just bound -> if n' > fromIntegral bound+          then return $ fromIntegral n+          else getBase' base n'+        Nothing -> getBase' base n'+    Nothing -> return $ fromIntegral n+
+ src/Fingerprint/BF93.hs view
@@ -0,0 +1,82 @@+module Fingerprint.BF93 (+    name+  , semantics+  ) where++import Prelude hiding (lookup)++import Control.Monad.State.Strict++import Data.Map (Map)++import System.Exit (exitWith, ExitCode (ExitSuccess))++import Env+import Instruction+import Ip+import Mode+import Semantics++-----------------------------------------------------------++name :: String+name = "BF93"++semantics :: (I i) => [(Char, Instruction i ())]+semantics = [+    ('B', bInstr)+  ]++string93ModeInstructions :: (I i) => (i -> Maybe (Instruction i ()), Map i (Maybe (Instruction i ())))+string93ModeInstructions = (,) (Just . pushInstr) $ buildInstructions [+    ('"', Just string93ModeInstr)+  ]++string93ModeInstr :: (I i) => Instruction i ()+string93ModeInstr = do+  modify $ withIp $ toggleMode mode+  modify $ withSemantics $ Semantics.toggleOverlay mode string93ModeInstructions+  where+    mode = Mode.String93++exitInstr :: (I i) => Instruction i ()+exitInstr = liftIO $ exitWith ExitSuccess++befunge93ModeInstructions :: (I i) => (i -> Maybe (Instruction i ()), Map i (Maybe (Instruction i ())))+befunge93ModeInstructions = (,) (const $ Just reverseInstr) $ buildInstructions [+    ('"', Just string93ModeInstr)+  , ('@', Just exitInstr)+  , (' ', Just spaceInstr)+  , ('+', Just addInstr)+  , ('-', Just subtractInstr)+  , ('*', Just multiplyInstr)+  , ('/', Just divideInstr)+  , ('%', Just remainderInstr)+  , ('`', Just greaterThanInstr)+  , ('>', Just goEastInstr)+  , ('<', Just goWestInstr)+  , ('^', Just goNorthInstr)+  , ('v', Just goSouthInstr)+  , ('?', Just goAwayInstr)+  , ('_', Just eastWestIfInstr)+  , ('|', Just northSouthIfInstr)+  , (':', Just duplicateInstr)+  , ('\\',Just swapInstr)+  , ('$', Just popInstr_)+  , ('.', Just outputDecimalInstr)+  , (',', Just outputCharacterInstr)+  , ('#', Just trampolineInstr)+  , ('g', Just getInstr)+  , ('p', Just putInstr)+  , ('&', Just inputDecimalInstr)+  , ('~', Just inputCharacterInstr)+  , ('!', Just logicalNotInstr)+  ]++bInstr :: (I i) => Instruction i ()+bInstr = do+  modify $ withIp $ toggleMode mode+  modify $ withSemantics $ Semantics.toggleOverlay mode befunge93ModeInstructions+  where+    mode = Mode.Befunge93+
+ src/Fingerprint/BOOL.hs view
@@ -0,0 +1,32 @@+module Fingerprint.BOOL (+    name+  , semantics+  ) where++import Instruction++-----------------------------------------------------------++name :: String+name = "BOOL"++semantics :: (I i) => [(Char, Instruction i ())]+semantics = [+    ('A', aInstr)+  , ('N', logicalNotInstr)+  , ('O', oInstr)+  , ('X', xInstr)+  ]++aInstr :: (I i) => Instruction i ()+aInstr = op2Instr $ \x y -> if x == 0 then 0 else y++oInstr :: (I i) => Instruction i ()+oInstr = op2Instr $ \x y -> if x /= 0 then x else y++xInstr :: (I i) => Instruction i ()+xInstr = op2Instr $ \x y -> case () of+  _ | x == 0 && y == 0 -> 0+    | x == 0 || y == 0 -> 1+    | otherwise -> 0+
+ src/Fingerprint/BZRO.hs view
@@ -0,0 +1,86 @@+module Fingerprint.BZRO (+    name+  , semantics+  ) where++import Control.Monad.State.Strict++import Data.Char (chr, ord)+import Data.Map (Map)+import Data.Maybe (fromMaybe)+import Data.Tuple.Map++import Space.Cell++import Env+import Instruction+import Ip+import Mode+import qualified Semantics++-----------------------------------------------------------++name :: String+name = "BZRO"++semantics :: (I i) => [(Char, Instruction i ())]+semantics = [+    ('B', bInstr)+  ]++runInstructionInstr :: (I i) => Char -> Instruction i ()+runInstructionInstr c = do+  sem <- gets $ Semantics.removeOverlay Mode.Bizarro . getSemantics . currentIp+  fromMaybe (unknownInstr i) $ Semantics.lookup i sem+  where+    i = ordCell $ charToCell c++bizarroModeInstructions :: (I i) => (i -> Maybe (Instruction i ()), Map i (Maybe (Instruction i ())))+bizarroModeInstructions = (,) f $ buildInstructions $ map (map2 $ Just . runInstructionInstr) [+    ('>', '<')+  , ('<', '>')+  , ('^', 'v')+  , ('v', '^')+  , ('h', 'l')+  , ('l', 'h')+  , ('[', ']')+  , (']', '[')+  , ('_', '|')+  , ('|', '_')+  , ('(', ')')+  , (')', '(')+  , ('{', '}')+  , ('}', '{')+  , ('+', '-')+  , ('-', '+')+  , ('*', '/')+  , ('/', '*')+  , ('i', 'o')+  , ('o', 'i')+  , ('&', '.')+  , ('.', '&')+  , ('~', ',')+  , (',', '~')+  , ('g', 'p')+  , ('p', 'g')+  , ('@', 'q')+  , ('q', '@')+  , ('\'','"')+  , ('"','\'')+  ]+  where+    f x = case cellToChar $ chrCell x of+      Just c+        | c `elem` ['0'..'9'] -> Just $ map runInstructionInstr "fedcba9876" !! (ord c - ord '0')+        | c `elem` ['a'..'f'] -> Just $ map runInstructionInstr "543210" !! (ord c - ord 'a')+        | c `elem` ['A'..'Z'] -> Just $ runInstructionInstr $ chr $ ord 'Z' + ord 'A' - ord c+        | otherwise -> Nothing+      Nothing -> Nothing++bInstr :: (I i) => Instruction i ()+bInstr = do+  modify $ withIp $ toggleMode mode+  modify $ withSemantics $ Semantics.toggleOverlay mode bizarroModeInstructions+  where+    mode = Mode.Bizarro+
+ src/Fingerprint/CPLI.hs view
@@ -0,0 +1,71 @@+module Fingerprint.CPLI (+    name+  , semantics+  ) where++import Control.Monad++import Data.Maybe (isNothing)++import Instruction+import Math++-----------------------------------------------------------++name :: String+name = "CPLI"++semantics :: (I i) => [(Char, Instruction i ())]+semantics = [+    ('A', aInstr)+  , ('D', dInstr)+  , ('M', mInstr)+  , ('S', sInstr)+  , ('O', oInstr)+  , ('V', vInstr)+  ]++complexInstr :: (I i) => (i -> i -> i -> i -> (i, i)) -> Instruction i ()+complexInstr op = do+  d <- popInstr+  c <- popInstr+  b <- popInstr +  a <- popInstr+  let (e, f) = op a b c d+  pushInstr e+  pushInstr f++aInstr :: (I i) => Instruction i ()+aInstr = complexInstr $ \a b c d -> (a + c, b + d)++mapPair :: (a -> b) -> (a, a) -> (b, b)+mapPair f (x, y) = (f x, f y)++dInstr :: (I i) => Instruction i ()+dInstr = complexInstr $ \a' b' c' d' -> let+  [a, b, c, d] = map fromIntegral [a', b', c', d']+  denom = c*c + d*d+  in mapPair fromInteger ((a*c + b*d) `div` denom, (b*c - a*d) `div` denom)++mInstr :: (I i) => Instruction i ()+mInstr = complexInstr $ \a' b' c' d' -> let+  [a, b, c, d] = map fromIntegral [a', b', c', d']+  in mapPair fromInteger (a*c - b*d, b*c + a*d)++sInstr :: (I i) => Instruction i ()+sInstr = complexInstr $ \a b c d -> (a - c, b - d)++oInstr :: (I i) => Instruction i ()+oInstr = do+  b <- popInstr+  a <- popInstr+  let signB = if b >= 0 then "+" else "-"+  outcome <- tryLiftIO $ putStr $ '(' : show a ++ signB ++ show (abs b) ++ "i) "+  when (isNothing outcome) reverseInstr+  ++vInstr :: (I i) => Instruction i ()+vInstr = op2Instr $ \a' b' -> let+  (a, b) = mapPair fromIntegral (a', b')+  in fromInteger $ squareRoot $ a*a + b*b+
+ src/Fingerprint/FIXP.hs view
@@ -0,0 +1,120 @@+module Fingerprint.FIXP (+    name+  , semantics+  ) where++import Prelude hiding (pi)+import qualified Prelude++import Control.Monad.State.Strict++import Data.Bits ((.&.), (.|.), xor)++import Instruction+import Math+import Random++-----------------------------------------------------------++name :: String+name = "FIXP"++semantics :: (I i) => [(Char, Instruction i ())]+semantics = [+    ('A', aInstr)+  , ('B', bInstr)+  , ('C', cInstr)+  , ('D', dInstr)+  , ('I', iInstr)+  , ('J', jInstr)+  , ('N', nInstr)+  , ('O', oInstr)+  , ('P', pInstr)+  , ('Q', qInstr)+  , ('R', rInstr)+  , ('S', sInstr)+  , ('T', tInstr)+  , ('U', uInstr)+  , ('V', vInstr)+  , ('X', xInstr)+  ]++trigInstr :: (I i) => (Double -> Double) -> Instruction i ()+trigInstr op = opInstr $ \deg -> let+  deg' = fromInteger $ fromIntegral deg `mod` (360 * scale)+  rad = pi * deg' / scale / 180+  res = op rad+  in round $ res * scale+  where+    pi = Prelude.pi+    scale :: (Num a) => a+    scale = 10000++itrigInstr :: (I i) => (Double -> Double) -> Instruction i ()+itrigInstr op = opInstr $ \x -> let+  x' = fromIntegral x / scale+  rad = op x'+  deg = rad * 180 / pi+  in round $ deg * scale+  where+    pi = Prelude.pi+    scale :: (Num a) => a+    scale = 10000++aInstr :: (I i) => Instruction i ()+aInstr = op2Instr (.&.)++bInstr :: (I i) => Instruction i ()+bInstr = itrigInstr acos++cInstr :: (I i) => Instruction i ()+cInstr = trigInstr cos++dInstr :: (I i) => Instruction i ()+dInstr = popInstr >>= liftIO . uniformN >>= pushInstr+  where+    uniformN n = liftM (signum n *) $ uniformR (0, abs n)++iInstr :: (I i) => Instruction i ()+iInstr = trigInstr sin++jInstr :: (I i) => Instruction i ()+jInstr = itrigInstr asin++nInstr :: (I i) => Instruction i ()+nInstr = opInstr negate++oInstr :: (I i) => Instruction i ()+oInstr = op2Instr (.|.)++pInstr :: (I i) => Instruction i ()+pInstr = opInstr $ \x -> fromInteger $ (fromIntegral x * pi) `div` pow10+  where+    pi = 3141592653589793+    pow10 = 10 ^ (length (show pi) - 1)++qInstr :: (I i) => Instruction i ()+qInstr = opInstr $ \x -> if x >= 0+  then fromInteger $ squareRoot $ fromIntegral x+  else x++rInstr :: (I i) => Instruction i ()+rInstr = op2Instr $ \x y -> if y >= 0+  then x ^ y+  else 0++sInstr :: (I i) => Instruction i ()+sInstr = opInstr signum++tInstr :: (I i) => Instruction i ()+tInstr = trigInstr tan++uInstr :: (I i) => Instruction i ()+uInstr = itrigInstr atan++vInstr :: (I i) => Instruction i ()+vInstr = opInstr abs++xInstr :: (I i) => Instruction i ()+xInstr = op2Instr xor+
+ src/Fingerprint/HRTI.hs view
@@ -0,0 +1,64 @@+module Fingerprint.HRTI (+    name+  , semantics+  ) where++import Control.Monad.State.Strict++import System.Time++import Env+import Instruction+import Ip++-----------------------------------------------------------++name :: String+name = "HRTI"++semantics :: (I i) => [(Char, Instruction i ())]+semantics = [+    ('G', gInstr)+  , ('M', mInstr)+  , ('T', tInstr)+  , ('E', eInstr)+  , ('S', sInstr)+  ]++ten6 :: Integer+ten6 = 10 ^ (6 :: Integer)++diffMicro :: (I i) => ClockTime -> ClockTime -> i+diffMicro x = fromInteger . (`div` ten6) . tdPicosec . diffClockTimes x++gInstr :: (I i) => Instruction i ()+gInstr = do+  t <- liftIO $ do+    _ <- getClockTime+    x <- getClockTime+    y <- getClockTime+    return $ diffMicro y x+  pushInstr t++mInstr :: (I i) => Instruction i ()+mInstr = do+  t <- liftIO getClockTime+  modify $ withIp $ \ip -> ip { hrtiMark = Just t }++tInstr :: (I i) => Instruction i ()+tInstr = do+  ip <- gets currentIp+  case hrtiMark ip of+    Nothing -> reverseInstr+    Just t -> do+      t' <- liftIO getClockTime+      pushInstr $ diffMicro t' t++eInstr :: (I i) => Instruction i ()+eInstr = modify $ withIp $ \ip -> ip { hrtiMark = Nothing }++sInstr :: (I i) => Instruction i ()+sInstr = do+  pico <- liftIO $ liftM ctPicosec $ getClockTime >>= toCalendarTime+  pushInstr $ fromInteger $ pico `div` ten6+
+ src/Fingerprint/MODE.hs view
@@ -0,0 +1,109 @@+module Fingerprint.MODE (+    name+  , semantics+  ) where++import Control.Monad.State.Strict++import Data.Map (Map)+import Data.Vector++import Space.Cell+import Space.Space++import Env+import Instruction+import Ip+import qualified Mode+import qualified Semantics++-----------------------------------------------------------++name :: String+name = "MODE"++semantics :: (I i) => [(Char, Instruction i ())]+semantics = [+    ('H', hInstr)+  , ('I', iInstr)+  , ('Q', qInstr)+  , ('S', sInstr)+  ]++-----------------------------------------------------------++addDeltaInstr :: (I i) => [i] -> Instruction i ()+addDeltaInstr ds = do+  env <- get+  let dim = getDim env+      delta = getDelta $ currentIp env+      delta' = unVector $ delta + mkVector (take dim $ ds ++ repeat 0)+  setDeltaInstr delta'++hoverGoEastInstr :: (I i) => Instruction i ()+hoverGoEastInstr = addDeltaInstr [1]++hoverGoWestInstr :: (I i) => Instruction i ()+hoverGoWestInstr = addDeltaInstr [-1]++hoverGoNorthInstr :: (I i) => Instruction i ()+hoverGoNorthInstr = guardDim 2 $ addDeltaInstr [0, -1]++hoverGoSouthInstr :: (I i) => Instruction i ()+hoverGoSouthInstr = guardDim 2 $ addDeltaInstr [0, 1]++hoverEastWestIfInstr :: (I i) => Instruction i ()+hoverEastWestIfInstr = ifInstr hoverGoWestInstr hoverGoEastInstr++hoverNorthSouthIfInstr :: (I i) => Instruction i ()+hoverNorthSouthIfInstr = guardDim 2 $ ifInstr hoverGoNorthInstr hoverGoSouthInstr++hoverModeInstructions :: (I i) => (i -> Maybe (Instruction i ()), Map i (Maybe (Instruction i ())))+hoverModeInstructions = (,) (const Nothing) $ buildInstructions [+    ('>', Just hoverGoEastInstr)+  , ('<', Just hoverGoWestInstr)+  , ('^', Just hoverGoNorthInstr)+  , ('v', Just hoverGoSouthInstr)+  , ('|', Just hoverNorthSouthIfInstr)+  , ('_', Just hoverEastWestIfInstr)+  ]++-----------------------------------------------------------++setCurrentCellInstr :: (I i) => Char -> Instruction i ()+setCurrentCellInstr c = do+  pos <- gets $ getPos . currentIp+  modify $ withSpace $ \s -> putCell s (charToCell c) pos++switchModeInstructions :: (I i) => (i -> Maybe (Instruction i ()), Map i (Maybe (Instruction i ())))+switchModeInstructions = (,) (const Nothing) $ buildInstructions [+    ('[', Just $ setCurrentCellInstr ']' >> turnLeftInstr)+  , (']', Just $ setCurrentCellInstr '[' >> turnRightInstr)+  , ('{', Just $ setCurrentCellInstr '}' >> beginBlockInstr)+  , ('}', Just $ setCurrentCellInstr '{' >> endBlockInstr)+  , ('(', Just $ setCurrentCellInstr ')' >> loadSemanticsInstr)+  , (')', Just $ setCurrentCellInstr '(' >> unloadSemanticsInstr)+  ]++-----------------------------------------------------------++hInstr :: (I i) => Instruction i ()+hInstr = do+  modify $ withIp $ toggleMode mode+  modify $ withSemantics $ Semantics.toggleOverlay mode hoverModeInstructions+  where+    mode = Mode.Hover++iInstr :: (I i) => Instruction i ()+iInstr = modify $ withIp $ toggleMode Mode.Invert++qInstr :: (I i) => Instruction i ()+qInstr = modify $ withIp $ toggleMode Mode.Queue++sInstr :: (I i) => Instruction i ()+sInstr = do+  modify $ withIp $ toggleMode mode+  modify $ withSemantics $ Semantics.toggleOverlay mode switchModeInstructions+  where+    mode = Mode.Switch+
+ src/Fingerprint/MODU.hs view
@@ -0,0 +1,28 @@+module Fingerprint.MODU (+    name+  , semantics+  ) where++import Instruction++-----------------------------------------------------------++name :: String+name = "MODU"++semantics :: (I i) => [(Char, Instruction i ())]+semantics = [+    ('M', mInstr)+  , ('U', uInstr)+  , ('R', rInstr)+  ]++mInstr :: (I i) => Instruction i ()+mInstr = op2Instr $ guardZero mod++uInstr :: (I i) => Instruction i ()+uInstr = op2Instr $ guardZero (\x -> abs . mod x)++rInstr :: (I i) => Instruction i ()+rInstr = op2Instr $ guardZero rem+
+ src/Fingerprint/NOP.hs view
@@ -0,0 +1,15 @@+module Fingerprint.NOP (+    name+  , semantics+  ) where++import Instruction++-----------------------------------------------------------++name :: String+name = "NOP"++semantics :: (I i) => [(Char, Instruction i ())]+semantics = zip ['A'..'Z'] $ repeat nopInstr+
+ src/Fingerprint/NULL.hs view
@@ -0,0 +1,15 @@+module Fingerprint.NULL (+    name+  , semantics+  ) where++import Instruction++-----------------------------------------------------------++name :: String+name = "NULL"++semantics :: (I i) => [(Char, Instruction i ())]+semantics = zip ['A'..'Z'] $ repeat reverseInstr+
+ src/Fingerprint/ORTH.hs view
@@ -0,0 +1,96 @@+module Fingerprint.ORTH (+    name+  , semantics+  ) where++import Control.Monad.State.Strict++import Data.Bits+import Data.Maybe (fromMaybe)+import Data.Vector++import Space.Cell+import Space.Space++import Env+import Instruction+import Ip++-----------------------------------------------------------++name :: String+name = "ORTH"++semantics :: (I i) => [(Char, Instruction i ())]+semantics = [+    ('A', aInstr)+  , ('E', eInstr)+  , ('G', gInstr)+  , ('O', oInstr)+  , ('P', pInstr)+  , ('S', sInstr)+  , ('V', vInstr)+  , ('W', wInstr)+  , ('X', xInstr)+  , ('Y', yInstr)+  , ('Z', zInstr)+  ]++aInstr :: (I i) => Instruction i ()+aInstr = op2Instr (.&.)++oInstr :: (I i) => Instruction i ()+oInstr = op2Instr (.|.)++eInstr :: (I i) => Instruction i ()+eInstr = op2Instr xor++overlay :: [Maybe a] -> Vector a -> Vector a+overlay = zipWithV f . mkVector . (++ repeat Nothing)+  where+    f = flip fromMaybe++xInstr :: (I i) => Instruction i ()+xInstr = do+  x <- popInstr+  modify $ withIp $ \ip -> ip { getPos = overlay [Just x] $ getPos ip }++yInstr :: (I i) => Instruction i ()+yInstr = do+  x <- popInstr+  modify $ withIp $ \ip -> ip { getPos = overlay [Nothing, Just x] $ getPos ip }++vInstr :: (I i) => Instruction i ()+vInstr = do+  x <- popInstr+  modify $ withIp $ \ip -> ip { getDelta = overlay [Just x] $ getDelta ip }++wInstr :: (I i) => Instruction i ()+wInstr = do+  x <- popInstr+  modify $ withIp $ \ip -> ip { getDelta = overlay [Nothing, Just x] $ getDelta ip }++gInstr :: (I i) => Instruction i ()+gInstr = guardDim 2 $ do+  loc <- liftM reverseV $ popVectorInstr (2 :: Int)+  env <- get+  let dim = getDim env+      s = getSpace env+      x = ordCell $ cellAt s $ takeV dim $ loc `append` 0+  pushInstr x++pInstr :: (I i) => Instruction i ()+pInstr = guardDim 2 $ do+  dim <- gets getDim+  loc <- liftM reverseV $ popVectorInstr (2 :: Int)+  x <- popInstr+  modify $ withSpace $ \s -> putCell s (chrCell x) $ takeV dim $ loc `append` 0++zInstr :: (I i) => Instruction i ()+zInstr = ifInstr nopInstr trampolineInstr++sInstr :: (I i) => Instruction i ()+sInstr = do+  s <- liftM (map $ fromMaybe '?') popStringInstr+  liftIO $ putStr s+
+ src/Fingerprint/RECD.hs view
@@ -0,0 +1,135 @@+module Fingerprint.RECD (+    name+  , semantics+  ) where++import Control.Monad.State.Strict++import Data.Foldable (foldl', toList)+import Data.List (genericTake, genericDrop, intersperse)+import Data.Map (Map)+import Data.Maybe (fromMaybe)+import Data.Sequence (Seq)++import Env+import Instruction+import Ip+import Mode+import Semantics++-----------------------------------------------------------++name :: String+name = "RECD"++semantics :: (I i) => [(Char, Instruction i ())]+semantics = [+    ('C', cInstr)+  , ('L', lInstr)+  , ('N', nInstr)+  , ('R', rInstr)+  , ('P', pInstr)+  , ('Q', qInstr)+  ]++recordingMode :: Mode+recordingMode = Mode.Record++learnInstructions :: (I i) => (i -> Maybe (Instruction i ()), Map i (Maybe (Instruction i ())))+learnInstructions = (,) (Just . learnInstr_) $ buildInstructions [+    ('L', Just lInstr)+  ]++recordInstructions :: (I i) => (i -> Maybe (Instruction i ()), Map i (Maybe (Instruction i ())))+recordInstructions = (,) (Just . recordInstr) $ buildInstructions [+    ('R', Just rInstr)+  ]++learnInstr_ :: (I i) => i -> Instruction i ()+learnInstr_ i = learnInstr i >> return ()++learnInstr :: (I i) => i -> Instruction i (Instruction i ())+learnInstr i = do+  sem <- gets $ Semantics.removeOverlay recordingMode . getSemantics . currentIp+  let instr = fromMaybe (unknownInstr i) $ Semantics.lookup i sem+  modify $ withIp $ record instr+  recordLen <- gets $ getRecordLength . currentIp+  modify $ withIp $ setRecordLength $! recordLen + 1+  return instr++recordInstr :: (I i) => i -> Instruction i ()+recordInstr = join . learnInstr++cInstr :: (I i) => Instruction i ()+cInstr = do+  recording <- gets $ testMode Mode.Record . currentIp+  learning <- gets $ testMode Mode.Learn . currentIp+  if recording || learning+    then reverseInstr+    else modify $ withIp clearRecordings++seqLength :: (Integral i) => Seq a -> i+seqLength = foldl' (\n _ -> n + 1) 0++nInstr :: (I i) => Instruction i ()+nInstr = gets (seqLength . getRecordings . currentIp) >>= pushInstr++lInstr :: (I i) => Instruction i ()+lInstr = do+  recording <- gets $ testMode Mode.Record . currentIp+  if recording+    then reverseInstr+    else do+      learning <- gets $ testMode Mode.Learn . currentIp+      when learning $ do+        recordLen <- gets $ getRecordLength . currentIp+        modify $ withIp $ setRecordLength 0+        pushInstr recordLen+      modify $ withIp $ toggleMode Mode.Learn+      modify $ withSemantics $ Semantics.toggleOverlay recordingMode learnInstructions++rInstr :: (I i) => Instruction i ()+rInstr = do+  learning <- gets $ testMode Mode.Learn . currentIp+  if learning+    then reverseInstr+    else do+      recording <- gets $ testMode Mode.Record . currentIp+      when recording $ do+        recordLen <- gets $ getRecordLength . currentIp+        modify $ withIp $ setRecordLength 0+        pushInstr recordLen+      modify $ withIp $ toggleMode Mode.Record+      modify $ withSemantics $ Semantics.toggleOverlay recordingMode recordInstructions++getRecordingsInstr :: (I i) => Instruction i [Instruction i ()]+getRecordingsInstr = do+  idx <- popInstr+  n <- popInstr+  let takeN = if n >= 0+        then genericTake n+        else id+  gets (takeN . genericDrop idx . toList . getRecordings . currentIp) ++pInstr :: (I i) => Instruction i ()+pInstr = do+  recording <- gets $ testMode Mode.Record . currentIp+  learning <- gets $ testMode Mode.Learn . currentIp+  if recording || learning+    then reverseInstr+    else do+      modify $ withIp $ addMode Mode.Learn . addMode Mode.Record+      getRecordingsInstr >>= sequence_ . intersperse trampolineInstr+      modify $ withIp $ removeMode Mode.Learn . removeMode Mode.Record++qInstr :: (I i) => Instruction i ()+qInstr = do+  recording <- gets $ testMode Mode.Record . currentIp+  learning <- gets $ testMode Mode.Learn . currentIp+  if recording || learning+    then reverseInstr+    else do+      modify $ withIp $ addMode Mode.Learn . addMode Mode.Record+      getRecordingsInstr >>= sequence_+      modify $ withIp $ removeMode Mode.Learn . removeMode Mode.Record+
+ src/Fingerprint/REFC.hs view
@@ -0,0 +1,43 @@+module Fingerprint.REFC (+    name+  , semantics+  ) where++import Control.Monad.State.Strict++import qualified Data.Map as Map++import System.Exit (exitFailure)++import Env+import Instruction++-----------------------------------------------------------++name :: String+name = "REFC"++semantics :: (I i) => [(Char, Instruction i ())]+semantics = [+    ('R', rInstr)+  , ('D', dInstr)+  ]++rInstr :: (I i) => Instruction i ()+rInstr = do+  refs <- gets getValidReferences+  case refs of+    [] -> liftIO $ do+      putStrLn "REFC fingerprint: Cannot create a unique reference for vector."+      exitFailure+    r : rs -> do+      vec <- popDimVectorInstr+      pushInstr r+      refMap <- gets $ Map.insert r vec . getReferenceMap+      modify $ \env -> env { getReferenceMap = refMap, getValidReferences = rs }++dInstr :: (I i) => Instruction i ()+dInstr = do+  r <- popInstr+  gets getReferenceMap >>= maybe reverseInstr pushVectorInstr . Map.lookup r+
+ src/Fingerprint/ROMA.hs view
@@ -0,0 +1,44 @@+module Fingerprint.ROMA (+    name+  , semantics+  ) where++import Instruction++-----------------------------------------------------------++name :: String+name = "ROMA"++semantics :: (I i) => [(Char, Instruction i ())]+semantics = [+    ('C', cInstr)+  , ('D', dInstr)+  , ('I', iInstr)+  , ('L', lInstr)+  , ('M', mInstr)+  , ('V', vInstr)+  , ('X', xInstr)+  ]++cInstr :: (I i) => Instruction i ()+cInstr = pushInstr 100++dInstr :: (I i) => Instruction i ()+dInstr = pushInstr 500++iInstr :: (I i) => Instruction i ()+iInstr = pushInstr 1++lInstr :: (I i) => Instruction i ()+lInstr = pushInstr 50++mInstr :: (I i) => Instruction i ()+mInstr = pushInstr 1000++vInstr :: (I i) => Instruction i ()+vInstr = pushInstr 5++xInstr :: (I i) => Instruction i ()+xInstr = pushInstr 10+
+ src/Fingerprint/STRN.hs view
@@ -0,0 +1,168 @@+module Fingerprint.STRN (+    name+  , semantics+  ) where++import Control.Monad.State.Strict++import Data.Char (isDigit, isSpace)+import Data.IntegralLike+import Data.List (tails, isPrefixOf, genericTake, genericDrop, genericLength, foldl')+import Data.Maybe (fromMaybe, listToMaybe)+import Data.MaybeBounded+import Data.Vector++import Space.Cell+import Space.Space++import System.IO (hFlush, stdout)++import Env+import Instruction+import Ip++-----------------------------------------------------------++name :: String+name = "STRN"++semantics :: (I i) => [(Char, Instruction i ())]+semantics = [+    ('A', aInstr)+  , ('C', cInstr)+  , ('D', dInstr)+  , ('F', fInstr)+  , ('G', gInstr)+  , ('I', iInstr)+  , ('L', lInstr)+  , ('M', mInstr)+  , ('N', nInstr)+  , ('P', pInstr)+  , ('R', rInstr)+  , ('S', sInstr)+  , ('V', vInstr)+  ]++pushStringInstr :: (I i) => [i] -> Instruction i ()+pushStringInstr str = do+  pushInstr 0+  pushVectorInstr $ mkVector $ reverse str++aInstr :: (I i) => Instruction i ()+aInstr = do+  s1 <- popStringInstr'+  s2 <- popStringInstr'+  pushStringInstr $ s1 ++ s2++cInstr :: (I i) => Instruction i ()+cInstr = do+  s1 <- popStringInstr'+  s2 <- popStringInstr'+  pushInstr $ case compare s1 s2 of+    GT -> 1+    LT -> -1+    EQ -> 0++dInstr :: (I i) => Instruction i ()+dInstr = do+  s <- liftM (map $ fromMaybe '?') popStringInstr+  liftIO $ putStr s++search :: (Eq a) => [a] -> [a] -> [a]+search needle = fromMaybe [] . listToMaybe . filter (needle `isPrefixOf`) . tails++fInstr :: (I i) => Instruction i ()+fInstr = do+  s1 <- popStringInstr'+  s2 <- popStringInstr'+  pushStringInstr $ search s2 s1++gInstr :: (I i) => Instruction i ()+gInstr = do+  env <- get+  let dim = getDim env+      space = getSpace env+      east = takeV dim $ 1 `cons` 0+      so = getStorageOffset $ currentIp env+      (minC, _, space') = minMaxCoords space+      minX = head $ unVector minC+      wrappingAdd v w  = let z = v + w+        in if inBounds space' z+          then z+          else minX `cons` (dropV 1 z)+  pos <- popDimVectorInstr+  let poses = iterate (wrappingAdd east) $ pos + so+      cells = map (cellAt space) poses+      vals = map ordCell cells+      str = takeWhile (/= 0) vals+  modify $ withSpace $ const space'+  pushStringInstr str++iInstr :: (I i) => Instruction i ()+iInstr = do+  str <- liftIO $ do+    hFlush stdout+    getLine+  pushStringInstr $ map asIntegral str++lInstr :: (I i) => Instruction i ()+lInstr = do+  n <- popInstr+  str <- popStringInstr'+  pushStringInstr $ genericTake n str++mInstr :: (I i) => Instruction i ()+mInstr = do+  n <- popInstr+  p <- popInstr+  str <- popStringInstr'+  pushStringInstr $ genericTake n $ genericDrop p str++nInstr :: (I i) => Instruction i ()+nInstr = do+  str <- popStringInstr'+  pushStringInstr str -- needs to be done like this because of Hover mode+  pushInstr $ genericLength str++pInstr :: (I i) => Instruction i ()+pInstr = do+  env <- get+  let dim = getDim env+      space = getSpace env+      east = takeV dim $ 1 `cons` 0+      so = getStorageOffset $ currentIp env+  pos <- popDimVectorInstr+  str <- liftM (++ [0]) popStringInstr'+  let cells = map chrCell str+      poses = iterate (east +) $ pos + so+      space' = foldl' (\s -> uncurry $ putCell s) space $ zip cells poses+  modify $ withSpace $ const space'++rInstr :: (I i) => Instruction i ()+rInstr = do+  n <- popInstr+  str <- popStringInstr'+  pushStringInstr $ reverse $ genericTake n $ reverse str++sInstr :: (I i) => Instruction i ()+sInstr = popInstr >>= pushStringInstr . map asIntegral . show++atoi :: (MaybeBounded i, Integral i) => String -> i+atoi str = n''+  where+    n'' = fromInteger $ maybe n' (min n' . fromIntegral) $ maybeMaxBound `asTypeOf` Just n''+    n' = maybe n (max n . fromIntegral) $ maybeMinBound `asTypeOf` Just n''+    n = case dropWhile isSpace str of+      "" -> 0+      '+':cs -> atoi' cs+      '-':cs -> negate $ atoi' cs+      cs -> atoi' cs++atoi' :: String -> Integer+atoi' = foldl' (\n c -> 10 * n + read [c]) 0 . takeWhile isDigit++vInstr :: (I i) => Instruction i ()+vInstr = do+  str <- liftM (map $ fromMaybe '?') popStringInstr+  pushInstr $ atoi str +
+ src/Fungi.hs view
@@ -0,0 +1,119 @@+module Fungi (+    main+  , mycology+  ) where++import Control.Exception (handle)+import Control.Monad++import Data.ByteSize (byteSize)+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as BS (hGetContents)+import qualified Data.History as History+import Data.Int+import Data.Maybe (fromMaybe)+import qualified Data.Set as Set++import Debug.Debug+import Debug.Debugger++import Space.Space++import System.Cmd (system)+import System.Environment (getArgs, withArgs)+import System.Exit (ExitCode (..))+import System.FilePath (takeExtension)+import System.IO hiding (hGetContents)++import qualified Text.Help.Fingerprint+import qualified Text.Help.Fungi++import Env+import Fingerprint+import Instruction+import Interpreter+import ProcessArgs+import qualified Version++-----------------------------------------------------------++mycology :: IO ExitCode+mycology = do+  removeTemps+  ret <- withArgs ["--unknown", "debug", "tests/mycology/mycology.b98"] main+  removeTemps+  return ret+  where+    removeTemps = system "rm tests/mycology/mycotmp*.tmp" >> return ()++main :: IO ExitCode+main = do+  mArgs <- liftM processArgs getArgs+  case mArgs of+    Nothing -> badArgs >> return (ExitFailure 1)+    Just args+      | argsHelp args -> Text.Help.Fungi.help >> return ExitSuccess+      | argsVersion args -> version >> return ExitSuccess+      | otherwise -> case argsFingerDoc args of+          Just fingerName -> Text.Help.Fingerprint.help fingerName >> return ExitSuccess+          Nothing -> case argsFile args of+            Nothing -> usage >> return ExitSuccess+            Just file -> readSourceFile file >>= startFungi args file++readSourceFile :: FilePath -> IO ByteString+readSourceFile file = withFile file ReadMode $ \hdl -> BS.hGetContents hdl++runFirst :: (Monad m) => [m (Maybe a)] -> m (Maybe a)+runFirst [] = return Nothing+runFirst (m:ms) = m >>= maybe (runFirst ms) (return . Just)++startFungi :: ProcessedArgs -> FilePath -> ByteString -> IO ExitCode+startFungi args file fileContents = do+  ret <- runFirst [+      whenSize Nothing $ runFungi (env :: Env Integer)+    , whenSize (byteSize (0 :: Int)) $ runFungi (env :: Env Int)+    , whenSize (byteSize (0 :: Int8)) $ runFungi (env :: Env Int8)+    , whenSize (byteSize (0 :: Int16)) $ runFungi (env :: Env Int16)+    , whenSize (byteSize (0 :: Int32)) $ runFungi (env :: Env Int32)+    , whenSize (byteSize (0 :: Int64)) $ runFungi (env :: Env Int64)+    ]+  maybe (usage >> return (ExitFailure 1)) return ret+  where+    dim = fromMaybe (detectDim file) $ argsDim args+    debugger :: (I i) => Debugger Env i+    debugger = Debugger {+        getDebugMode = argsDebugMode args+      , Debug.Debugger.runDebugger = Debug.Debug.runDebugger+      , getBreakPoints = Set.empty+      , getWatchExprs = Set.empty+      , getHistory = History.empty 0+      , getLocaleRads = (7, 3)+      }+    space :: (I i) => Space i+    space = mkSpace dim fileContents+    env :: (I i) => Env i+    env = mkEnv dim space (argsUnknownMode args) debugger file (argsFungeArgs args) fingerprints baseInstructions+    whenSize size action = if size == argsCellByteSize args+      then fmap Just $ handle return action+      else return Nothing++detectDim :: FilePath -> Int+detectDim file = case takeExtension file of+  ".uf" -> 1+  ".u98" -> 1+  ".bf" -> 2+  ".b98" -> 2+  ".tf" -> 3+  ".t98" -> 3+  _ -> 2++usage :: IO ()+usage = putStrLn "See --help for usage."++version :: IO ()+version = do+  putStrLn $ "Fungi version " ++ Version.version++badArgs :: IO ()+badArgs = putStrLn "Bad arguments." >> usage+
+ src/Instruction.hs view
@@ -0,0 +1,907 @@+module Instruction (+    I+  , Instruction+  , buildInstructions+  , baseInstructions+  , lookupInstruction+  , runCurrentInstruction+  , currentInstruction++  , guardDim+  , guardZero++  , ifInstr+  , moveByDeltaInstr+  , setDeltaInstr+  , setPosInstr+  , opInstr+  , op2Instr+  , pushVectorInstr+  , popInstr+  , popNInstr_+  , popVectorInstr+  , popDimVectorInstr+  , popStringInstr+  , popStringInstr'+  , tryLiftIO++  , nopInstr+  , pushInstr+  , trampolineInstr+  , reverseInstr+  , loadSemanticsInstr+  , unloadSemanticsInstr+  , beginBlockInstr+  , endBlockInstr+  , turnLeftInstr+  , turnRightInstr+  , putInstr+  , getInstr+  , logicalNotInstr+  , goWestInstr+  , goEastInstr+  , goNorthInstr+  , goSouthInstr+  , goLowInstr+  , goHighInstr+  , northSouthIfInstr+  , eastWestIfInstr+  , stopInstr+  , quitInstr+  , subtractInstr+  , addInstr+  , multiplyInstr+  , divideInstr+  , outputFileInstr+  , inputFileInstr+  , outputCharacterInstr+  , inputCharacterInstr+  , outputDecimalInstr+  , inputDecimalInstr+  , stringModeInstr+  , fetchCharacterInstr+  , unknownInstr+  , spaceInstr+  , remainderInstr+  , greaterThanInstr+  , goAwayInstr+  , duplicateInstr+  , swapInstr+  , popInstr_++  ) where++import Control.Exception (catch)+import Control.Monad.State.Strict++import Data.ByteSize+import qualified Data.ByteString.Char8 as BS (hGetContents, unpack)+import Data.Char (ord)+import Data.Deque+import qualified Data.Deque as Deque+import Data.I+import Data.IntegralLike+import Data.List (foldl', genericLength, genericReplicate, intercalate)+import Data.LogicalBits+import Data.MaybeBounded+import Data.Maybe (isNothing, fromMaybe)+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Stack as Stack+import Data.Tuple.Map+import Data.Vector++import Debug.Debugger++import Space.Cell+import Space.Space++import System.Cmd (system)+import System.Directory (canonicalizePath)+import System.Environment (getEnvironment)+import System.Exit (exitWith, exitFailure, ExitCode (..))+import System.FilePath (pathSeparator, takeDirectory, isAbsolute)+import System.IO (IOMode (..), withFile, hPutStr, hFlush, hGetChar, stdout, stdin)+import System.IO.Buffering (BufferMode (..), withBuffering)+import System.Random (randomRIO)+import System.Time (CalendarTime (..), getClockTime, toCalendarTime)++import Text.PrettyShow++import Env+import Ip+import qualified Mode+import qualified Semantics+import UnknownInstruction+import Version++-----------------------------------------------------------++infixr 9 `o`+o :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)+o = (.).(.)++numToBool :: (Eq a, Num a) => a -> Bool+numToBool 0 = False+numToBool _ = True++whileM :: (Monad m) => (a -> m Bool) -> (a -> m a) -> a -> m a+whileM mPred f x = mPred x >>= \bool -> if bool+  then f x >>= whileM mPred f+  else return x++whileM_ :: (Monad m) => m Bool -> m () -> m ()+whileM_ mBool m = whileM (const mBool) (const m) ()++genericReplicateM :: (Integral i, Monad m) => i -> m a -> m [a]+genericReplicateM = sequence `o` genericReplicate++genericReplicateM_ :: (Integral i, Monad m) => i -> m a -> m ()+genericReplicateM_ = sequence_ `o` genericReplicate++-----------------------------------------------------------++type Instruction i = StateT (Env i) IO++-----------------------------------------------------------++buildInstructions :: (Integral i, IntegralLike c) => [(c, v)] -> Map i v+buildInstructions = Map.fromList . map (map1 asIntegral)++baseInstructions :: (I i) => Map i (Instruction i ())+baseInstructions = buildInstructions $ [+    (' ', spaceInstr)+  , ('!', logicalNotInstr)+  , ('"', stringModeInstr)+  , ('#', trampolineInstr)+  , ('$', popInstr_)+  , ('%', remainderInstr)+  , ('&', inputDecimalInstr)+  , ('\'',fetchCharacterInstr)+  , ('(', loadSemanticsInstr)+  , (')', unloadSemanticsInstr)+  , ('*', multiplyInstr)+  , ('+', addInstr)+  , (',', outputCharacterInstr)+  , ('-', subtractInstr)+  , ('.', outputDecimalInstr)+  , ('/', divideInstr)+  , ('0', pushInstr 0)+  , ('1', pushInstr 1)+  , ('2', pushInstr 2)+  , ('3', pushInstr 3)+  , ('4', pushInstr 4)+  , ('5', pushInstr 5)+  , ('6', pushInstr 6)+  , ('7', pushInstr 7)+  , ('8', pushInstr 8)+  , ('9', pushInstr 9)+  , (':', duplicateInstr)+  , (';', jumpOverInstr)+  , ('<', goWestInstr)+  , ('=', executeInstr)+  , ('>', goEastInstr)+  , ('?', goAwayInstr)+  , ('@', stopInstr)+  , ('[', turnLeftInstr)+  , ('\\',swapInstr)+  , (']', turnRightInstr)+  , ('^', goNorthInstr)+  , ('_', eastWestIfInstr)+  , ('`', greaterThanInstr)+  , ('a', pushInstr 10)+  , ('b', pushInstr 11)+  , ('c', pushInstr 12)+  , ('d', pushInstr 13)+  , ('e', pushInstr 14)+  , ('f', pushInstr 15)+  , ('g', getInstr)+  , ('h', goHighInstr)+  , ('i', inputFileInstr)+  , ('j', jumpForwardInstr)+  , ('k', iterateInstr)+  , ('l', goLowInstr)+  , ('m', highLowIfInstr)+  , ('n', clearStackInstr)+  , ('o', outputFileInstr)+  , ('p', putInstr)+  , ('q', quitInstr)+  , ('r', reverseInstr)+  , ('s', storeCharacterInstr)+  , ('t', splitInstr)+  , ('u', stackUnderStackInstr)+  , ('v', goSouthInstr)+  , ('w', compareInstr)+  , ('x', absoluteDeltaInstr)+  , ('y', getSysInfoInstr)+  , ('z', nopInstr)+  , ('{', beginBlockInstr)+  , ('|', northSouthIfInstr)+  , ('}', endBlockInstr)+  , ('~', inputCharacterInstr)+  ] ++ zip ['A'..'Z'] (repeat reverseInstr)++lookupInstruction :: (I i) => i -> Instruction i ()+lookupInstruction i = do+  sem <- gets $ getSemantics . currentIp+  fromMaybe (unknownInstr i) $ Semantics.lookup i sem++unknownInstr :: (I i) => i -> Instruction i ()+unknownInstr i = do+  env <- get+  case getUnknownMode env of+    ReverseUnknown -> reverseInstr+    FailUnknown -> liftIO $ do+      printUnknown+      exitFailure+    DebugUnknown -> do+      liftIO $ do+        printUnknown+        pprint $ getPos $ currentIp env+      debug+      reverseInstr+  where+    printUnknown = putStrLn $ "\n\n*** Uknown instruction ord: " ++ pshow i++-----------------------------------------------------------++currentInstruction :: (I i) => Env i -> Instruction i ()+currentInstruction = lookupInstruction . ordCell . currentCell++runCurrentInstruction :: (I i) => Instruction i ()+runCurrentInstruction = do+  env <- get+  runDebugger (getDebugger env)+  env' <- get+  currentInstruction env'++debug :: Instruction i ()+debug = do+  modify $ withDebugger $ \d -> d { getDebugMode = DebugStep }+  gets getDebugger >>= runDebugger++-----------------------------------------------------------++popInstr_ :: (I i) => Instruction i ()+popInstr_ = popInstr >> return ()++pushVectorInstr :: (I i) => Vector i -> Instruction i ()+pushVectorInstr = mapM_ pushInstr . unVector++popVectorInstr :: (I i, Integral n) => n -> Instruction i (Vector i)+popVectorInstr = liftM mkVector . popNInstr++popNInstr :: (I i, Integral n) => n -> Instruction i [i]+popNInstr n = liftM reverse $ genericReplicateM n popInstr++popNInstr_ :: (I i, Integral n) => n -> Instruction i ()+popNInstr_ n = genericReplicateM_ n popInstr++popDimInstr :: (I i) => Instruction i [i]+popDimInstr = gets getDim >>= popNInstr++popDimVectorInstr :: (I i) => Instruction i (Vector i)+popDimVectorInstr = gets getDim >>= popVectorInstr++popStringInstr :: (I i) => Instruction i [Maybe Char]+popStringInstr = liftM (map $ cellToChar . chrCell) popStringInstr'++popStringInstr' :: (I i) => Instruction i [i]+popStringInstr' = do+  x <- popInstr+  if x == 0+    then return []+    else liftM (x :) popStringInstr'++guardDim :: (I i) => Int -> Instruction i () -> Instruction i ()+guardDim dim instr = do+  env <- get+  if getDim env < dim+    then reverseInstr+    else instr++opInstr :: (I i) => (i -> i) -> Instruction i ()+opInstr op = popInstr >>= pushInstr . op++op2Instr :: (I i) => (i -> i -> i) -> Instruction i ()+op2Instr op = do+  y <- popInstr +  x <- popInstr+  pushInstr $ op x y++-----------------------------------------------------------++nopInstr :: (I i) => Instruction i ()+nopInstr = return ()++-----------------------------------------------------------+-- Direction Changing+-----------------------------------------------------------++setDeltaInstr :: (I i) => [i] -> Instruction i ()+setDeltaInstr delta = do+  dim <- gets getDim+  let delta' = take dim $ delta ++ repeat 0+  modify $ withIp $ setDelta $ mkVector delta'++goEastInstr :: (I i) => Instruction i ()+goEastInstr = setDeltaInstr [1]++goWestInstr :: (I i) => Instruction i ()+goWestInstr = setDeltaInstr [-1]++goNorthInstr :: (I i) => Instruction i ()+goNorthInstr = guardDim 2 $ setDeltaInstr [0, -1]++goSouthInstr :: (I i) => Instruction i ()+goSouthInstr = guardDim 2 $ setDeltaInstr [0, 1]++goHighInstr :: (I i) => Instruction i ()+goHighInstr = guardDim 3 $ setDeltaInstr [0, 0, 1]++goLowInstr :: (I i) => Instruction i ()+goLowInstr = guardDim 3 $ setDeltaInstr [0, 0, -1]++randElem :: [a] -> IO a+randElem xs = (xs !!) `fmap` randomRIO (0, length xs - 1)++goAwayInstr :: (I i) => Instruction i ()+goAwayInstr = do+  dim <- gets getDim+  delta <- liftIO $ do+    dir <- randElem [-1, 1]+    axis <- randElem [0 .. dim - 1]+    return $ genericReplicate axis 0 ++ [dir]+  setDeltaInstr delta++turnRightInstr :: (I i) => Instruction i ()+turnRightInstr = guardDim 2 $ modify $ withIp turn+  where+    turn ip = setDelta (mkVector $ [-y, x] ++ zs) ip+      where+        ([x, y], zs) = splitAt 2 . unVector . getDelta $ ip++turnLeftInstr :: (I i) => Instruction i ()+turnLeftInstr = replicateM_ 3 turnRightInstr++reverseInstr :: (I i) => Instruction i ()+reverseInstr = modify $ withIp reverseIp++absoluteDeltaInstr :: (I i) => Instruction i ()+absoluteDeltaInstr = popDimInstr >>= setDeltaInstr++-----------------------------------------------------------+-- Flow Control+-----------------------------------------------------------++setPosInstr :: (I i) => Vector i -> Instruction i ()+setPosInstr = modify . withIp . setPos++trampolineInstr :: (I i) => Instruction i ()+trampolineInstr = do+  env <- get+  let s = getSpace env+      ip = currentIp env+      delta = getDelta ip+      pos = getPos ip+  modify $ withIp $ setPos $ (pos `travelBy` delta) s++trampolineBackInstr :: (I i) => Instruction i ()+trampolineBackInstr = reverseInstr >> trampolineInstr >> reverseInstr++moveByDeltaInstr :: (I i) => Instruction i ()+moveByDeltaInstr = modify $ withIp $ \ip -> let+  pos = getPos ip+  delta = getDelta ip+  in ip { getPos = pos + delta }++moveBackByDeltaInstr :: (I i) => Instruction i ()+moveBackByDeltaInstr = reverseInstr >> moveByDeltaInstr >> reverseInstr++stopInstr :: (I i) => Instruction i ()+stopInstr = modify $ \env -> let+  ip = currentIp env+  ident = getId ip+  env' = env { getValidIds = ident : getValidIds env }+  in killIp `withIp` env'++atInstr :: (I i) => Char -> Instruction i Bool+atInstr c = gets $ (charToCell c ==) . currentCell++spaceInstr :: (I i) => Instruction i ()+spaceInstr = whileM_ (atInstr ' ') trampolineInstr >> runCurrentInstruction++jumpOverInstr :: (I i) => Instruction i ()+jumpOverInstr = trampolineInstr >> jump >> trampolineInstr >> runCurrentInstruction+  where+    jump = whileM_ (liftM not $ atInstr ';') trampolineInstr++jumpForwardInstr :: (I i) => Instruction i ()+jumpForwardInstr = do+  n <- popInstr+  genericReplicateM_ (abs n) $ if n >= 0+    then trampolineInstr+    else trampolineBackInstr++quitInstr :: (I i) => Instruction i ()+quitInstr = do+  exitVal <- popInstr+  liftIO $ if exitVal == 0+    then exitWith ExitSuccess+    else let+      maxInt = fromIntegral (maxBound :: Int)+      exitVal' = fromIntegral $ min maxInt exitVal+      in exitWith $ ExitFailure exitVal'++anyM :: (Monad m) => [m Bool] -> m Bool+anyM = foldr (liftM2 (||)) $ return False++iterateInstr :: (I i) => Instruction i ()+iterateInstr = do+  initPos <- gets $ getPos . currentIp+  n <- popInstr+  trampolineInstr+  whileM_ (anyM $ map atInstr " ;") trampolineInstr+  instr <- gets currentInstruction+  when (n > 0) $ do+    setPosInstr initPos+    genericReplicateM_ n instr++-----------------------------------------------------------+-- Decision Making+-----------------------------------------------------------++logicalNotInstr :: (I i) => Instruction i ()+logicalNotInstr = opInstr (asIntegral . not . numToBool)++greaterThanInstr :: (I i) => Instruction i ()+greaterThanInstr = op2Instr (asIntegral `o` (>))++ifInstr :: (I i) => Instruction i a -> Instruction i a -> Instruction i a+ifInstr trueInstr falseInstr = popInstr >>= \n -> if n == 0+  then falseInstr+  else trueInstr++eastWestIfInstr :: (I i) => Instruction i ()+eastWestIfInstr = ifInstr goWestInstr goEastInstr++northSouthIfInstr :: (I i) => Instruction i ()+northSouthIfInstr = guardDim 2 $ ifInstr goNorthInstr goSouthInstr++highLowIfInstr :: (I i) => Instruction i ()+highLowIfInstr = guardDim 3 $ ifInstr goHighInstr goLowInstr++compareInstr :: (I i) => Instruction i ()+compareInstr = guardDim 2 $ do+  y <- popInstr+  x <- popInstr+  case compare x y of+    LT -> turnLeftInstr+    GT -> turnRightInstr+    EQ -> nopInstr++-----------------------------------------------------------+-- Integers+-----------------------------------------------------------++addInstr :: (I i) => Instruction i ()+addInstr = op2Instr (+)++subtractInstr :: (I i) => Instruction i ()+subtractInstr = op2Instr (-)++multiplyInstr :: (I i) => Instruction i ()+multiplyInstr = op2Instr (*)++guardZero :: (Eq a, Num a) => (a -> a -> a) -> (a -> a -> a)+guardZero f x y = if y == 0+  then 0+  else f x y++divideInstr :: (I i) => Instruction i ()+divideInstr = op2Instr $ guardZero div++remainderInstr :: (I i) => Instruction i ()+remainderInstr = op2Instr $ guardZero rem++-----------------------------------------------------------+-- Strings+-----------------------------------------------------------++stringModeInstructions :: (I i) => (i -> Maybe (Instruction i ()), Map i (Maybe (Instruction i ())))+stringModeInstructions = (,) (Just . pushInstr) $ buildInstructions [+    ('"', Just stringModeInstr)+  , (' ', Just sgmlSpaceInstr)+  ]+  where+    spaceOrd = ordCell $ charToCell ' '+    sgmlSpaceInstr = do+      pushInstr spaceOrd+      whileM_ (atInstr ' ') trampolineInstr+      moveBackByDeltaInstr++stringModeInstr :: (I i) => Instruction i ()+stringModeInstr = do+  modify $ withIp $ toggleMode mode+  modify $ withSemantics $ Semantics.toggleOverlay mode stringModeInstructions+  where+    mode = Mode.String++fetchCharacterInstr :: (I i) => Instruction i ()+fetchCharacterInstr = do+  trampolineInstr+  x <- gets $ ordCell . currentCell+  pushInstr x++storeCharacterInstr :: (I i) => Instruction i ()+storeCharacterInstr = do+  trampolineInstr+  pos <- gets $ getPos . currentIp+  pushVectorInstr pos+  putInstr++-----------------------------------------------------------+-- Stack Manipulation+-----------------------------------------------------------++popInstr :: (I i) => Instruction i i+popInstr = do+  qm <- gets $ testMode Mode.Queue . currentIp+  liftM (fromMaybe 0) $ if qm+    then do+      x <- gets $ bottom . currentToss+      modify $ withToss popBottom+      return x+    else do+      x <- gets $ Deque.top . currentToss+      modify $ withToss Deque.pop+      return x++pushInstr :: (I i) => i -> Instruction i ()+pushInstr n = do+  im <- gets $ testMode Mode.Invert . currentIp+  modify $ withToss $ if im+    then pushBottom n+    else Deque.push n++duplicateInstr :: (I i) => Instruction i ()+duplicateInstr = popInstr >>= replicateM_ 2 . pushInstr++swapInstr :: (I i) => Instruction i ()+swapInstr = replicateM 2 popInstr >>= mapM_ pushInstr++clearStackInstr :: (I i) => Instruction i ()+clearStackInstr = modify $ withToss $ const mkDeque++-----------------------------------------------------------+-- Stack Stack Manipulation+-----------------------------------------------------------++beginBlockInstr :: (I i) => Instruction i ()+beginBlockInstr = do+  n <- popInstr+  elts <- popVectorInstr n+  ip <- gets currentIp+  pushVectorInstr $ mkVector $ genericReplicate (negate n) 0+  pushVectorInstr $ getStorageOffset ip+  let so = getPos ip + getDelta ip+  modify $ \env -> setStorageOffset so `withIp` (Stack.push mkDeque `withSs` env)+  pushVectorInstr elts++guardSoss :: (I i) => Instruction i () -> Instruction i ()+guardSoss instr = do+  noSoss <- gets $ Stack.isEmpty . Stack.pop . currentSs+  if noSoss+    then reverseInstr+    else instr++endBlockInstr :: (I i) => Instruction i ()+endBlockInstr = guardSoss $ do+  n <- popInstr+  elts <- popVectorInstr n+  modify $ withSs Stack.pop+  popDimVectorInstr >>= modify . withIp . setStorageOffset+  if n >= 0+    then pushVectorInstr elts+    else popNInstr_ $ abs n++stackUnderStackInstr :: (I i) => Instruction i ()+stackUnderStackInstr = guardSoss $ do+  n <- popInstr+  case compare n 0 of+    GT -> do+      toss <- gets currentToss+      modify $ withSs Stack.pop+      elts <- popVectorInstr n+      modify $ withSs $ Stack.push toss+      pushVectorInstr $ reverseV elts+    LT -> do+      elts <- popVectorInstr $ abs n+      toss <- gets currentToss+      modify $ withSs Stack.pop+      pushVectorInstr $ reverseV elts+      modify $ withSs $ Stack.push toss+    EQ -> nopInstr++-----------------------------------------------------------+-- Funge-Space Storage+-----------------------------------------------------------++putInstr :: (I i) => Instruction i ()+putInstr = do+  loc <- popDimVectorInstr+  x <- popInstr+  offset <- gets $ getStorageOffset . currentIp+  modify $ withSpace $ \s -> putCell s (chrCell x) $ loc + offset++getInstr :: (I i) => Instruction i ()+getInstr = do+  loc <- popDimVectorInstr+  env <- get+  let s = getSpace env+      offset = getStorageOffset $ currentIp env+      x = ordCell $ cellAt s $ loc + offset+  pushInstr x++-----------------------------------------------------------+-- Standard Input/Output+-----------------------------------------------------------++tryLiftIO :: IO a -> Instruction i (Maybe a)+tryLiftIO io = liftIO $ catch (liftM Just io) $ \e -> const (return Nothing) (e :: IOError)++isDigit :: Char -> Bool+isDigit = (`elem` ['0'..'9'])++outputDecimalInstr :: (I i) => Instruction i ()+outputDecimalInstr = do+  x <- popInstr+  outcome <- tryLiftIO $ putStr $ show x ++ " "+  when (isNothing outcome) reverseInstr++outputCharacterInstr :: (I i) => Instruction i ()+outputCharacterInstr = do+  c <- liftM (fromMaybe '?' . cellToChar . chrCell) popInstr+  outcome <- tryLiftIO $ putChar c+  when (isNothing outcome) reverseInstr++inputCharacterInstr :: (I i) => Instruction i ()+inputCharacterInstr = do+  outcome <- tryLiftIO $ do+    hFlush stdout+    withBuffering NoBuffering stdin hGetChar+  case outcome of+    Nothing -> reverseInstr+    Just c -> let+      n = fromIntegral $ ord c+      in pushInstr n++inputDecimalInstr :: (I i) => Instruction i ()+inputDecimalInstr = do+  ident <- gets $ getId . currentIp+  outcome <- tryLiftIO $ do+    hFlush stdout+    withBuffering NoBuffering stdin $ const $ getDecimal ident+  maybe reverseInstr pushInstr outcome++getDecimal :: (I i) => i -> IO i+getDecimal iType = do+  c <- getChar+  let k = read [c] :: Integer+      k' = fromInteger k+  if isDigit c+    then case maybeMaxBound `asTypeOf` Just iType of+      Just bound -> if k > fromIntegral bound+        then getDecimal iType+        else getDecimal' k'+      Nothing -> getDecimal' k'+    else getDecimal iType++getDecimal' :: (I i) => i -> IO i+getDecimal' n = do+  c <- getChar+  if isDigit c+    then let+      k = read [c]+      n' = 10 * (fromIntegral n :: Integer) + k+      n'' = fromInteger n'+      in case maybeMaxBound `asTypeOf` Just n of+        Just bound -> if n' > fromIntegral bound+          then return n+          else getDecimal' n''+        Nothing -> getDecimal' n''+    else return n+    +-----------------------------------------------------------+-- File Input/Output+-----------------------------------------------------------++canonicalizePath' :: (I i) => FilePath -> Instruction i FilePath+canonicalizePath' path = if isAbsolute path+  then return path+  else do+    progName <- gets getProgName+    dir <- liftIO $ liftM takeDirectory $ canonicalizePath progName+    return $ dir ++ [pathSeparator] ++ path++inputFileInstr :: (I i) => Instruction i ()+inputFileInstr = do+  env <- get+  let space = getSpace env+      so = getStorageOffset $ currentIp env+      dim = getDim env+      east = takeV dim $ 1 `cons` 0+  mFilepath <- liftM sequence popStringInstr+  flag <- popInstr+  va <- liftM (so +) popDimVectorInstr+  case mFilepath of+    Nothing -> reverseInstr+    Just filepath -> do+      cfilepath <- canonicalizePath' filepath+      m_space_vb <- tryLiftIO $ if testLogicalBit flag 0+        then do+          cells <- withFile cfilepath ReadMode $ \handle -> liftM (map charToCell . BS.unpack) $ BS.hGetContents handle+          let space' = foldl' (\s (c, p) -> putCell s c p) space $ zip cells $ iterate (+ east) va+              vb = (takeV dim $ genericLength cells `cons` 0)+          return (space', vb)+        else do+          kidSpace <- withFile cfilepath ReadMode $ \handle -> do+            contents <- BS.hGetContents handle+            return $ mkSpace dim contents+          let (minPos, maxPos, _) = minMaxCoords kidSpace+              vb = maxPos - minPos + takeV dim 1+              space' = putSpaceAt va space kidSpace+          return (space', vb)+      case m_space_vb of+        Nothing -> reverseInstr+        Just (space', vb) -> do+          pushVectorInstr vb+          pushVectorInstr va+          modify $ withSpace $ const space'++linearize :: String -> String+linearize = unlines . map (reverse . dropWhile (== ' ') . reverse) . lines++outputFileInstr :: (I i) => Instruction i ()+outputFileInstr = do+  env <- get+  let dim = getDim env+      space = getSpace env+      so = getStorageOffset $ currentIp env+  mFilepath <- liftM sequence popStringInstr+  flag <- popInstr+  va <- popDimVectorInstr+  vb <- liftM (subtract $ takeV dim 1) popDimVectorInstr+  let va' = va + so+      (_ : ~(_ : as)) = unVector va+      (xb : ~(yb : _)) = unVector vb+      xs = [0 .. xb]+      ys = [0 .. yb]+      cellGrid = if dim == 1+        then [[cellAt space $ va' + mkVector [x] | x <- xs]]+        else [[cellAt space $ va' + mkVector (x : y : as) | x <- xs] | y <- ys]+      mStr = liftM unlines $ mapM (mapM cellToChar) cellGrid+  case liftM2 (,) mFilepath mStr of+    Nothing -> reverseInstr+    Just (filepath, str) -> do+      cfilepath <- canonicalizePath' filepath+      outcome <- tryLiftIO $ withFile cfilepath WriteMode $ \handle -> hPutStr handle $ if testLogicalBit flag 0+        then linearize str+        else str+      when (isNothing outcome) reverseInstr++-----------------------------------------------------------+-- System Execution+-----------------------------------------------------------++executeInstr :: (I i) => Instruction i ()+executeInstr = do+  mStr <- liftM sequence popStringInstr+  case mStr of+    Nothing -> pushInstr 1+    Just str -> do+      exitCode <- liftIO $ system str+      pushInstr $ fromIntegral $ case exitCode of+        ExitSuccess -> 0+        ExitFailure k -> k++-----------------------------------------------------------+-- System Information Retrieval+-----------------------------------------------------------++getSysInfoInstr :: (I i) => Instruction i ()+getSysInfoInstr = do+  envVars <- liftIO getEnvironment+  CalendarTime {+      ctYear = year+    , ctMonth = month+    , ctDay = day+    , ctHour = hour+    , ctMin = mins+    , ctSec = sec+    } <- liftIO $ getClockTime >>= toCalendarTime+  n <- popInstr+  env <- get+  let dim = getDim env+      dim' = fromIntegral dim+      ip = currentIp env+      space = getSpace env+      progName = getProgName env+      args = getFungeArgs env+      ss = getSs ip+      (minPos, maxPos, space') = minMaxCoords space+  do+  {- 20 -} pushVectorInstr $ joinStrs $ map (\(x, y) -> x ++ "=" ++ y) envVars+  {- 19 -} pushVectorInstr $ joinStrs $ progName : args+  {- 18 -} pushVectorInstr $ mkVector $ reverse $ map (fromIntegral . Deque.depth) $ Stack.toList ss+  {- 17 -} pushInstr $ fromIntegral $ Stack.depth ss+  {- 16 -} pushInstr $ fromIntegral $ hour * 256 * 256 + mins * 256 + sec+  {- 15 -} pushInstr $ fromIntegral $ (year - 1900) * 256 * 256 + (fromEnum month + 1) * 256 + day+  {- 14 -} pushVectorInstr $ maxPos - minPos+  {- 13 -} pushVectorInstr minPos+  {- 12 -} pushVectorInstr $ getStorageOffset ip+  {- 11 -} pushVectorInstr $ getDelta ip+  {- 10 -} pushVectorInstr $ getPos ip+  {- 09 -} pushInstr 0+  {- 08 -} pushInstr $ getId ip+  {- 07 -} pushInstr $ fromIntegral dim+  {- 06 -} pushInstr $ fromIntegral $ ord pathSeparator+  {- 05 -} pushInstr 1+  {- 04 -} pushInstr $ read $ filter isDigit version+  {- 03 -} pushInstr handprint+  {- 02 -} pushInstr $ maybe (-1) fromIntegral $ byteSize n+  {- 01 -} pushInstr $ 0x01 + 0x02 + 0x04 + 0x08 + 0x10+  when (n > 0) $ do+    cell <- gets $ fromMaybe 0 . Deque.dig (n - 1) . currentToss+    put env+    pushInstr cell+  when (n <= 0 || (9 + 3 * dim' < n && n <= 9 + 5 * dim')) $ modify $ withSpace $ const space' +  where+    joinStrs = mkVector . map (fromIntegral . ord) . ("\0\0\0" ++) . intercalate "\0" . map reverse++-----------------------------------------------------------+-- Fingerprints+-----------------------------------------------------------++fingerprintId :: (Integral i) => Vector i -> Integer+fingerprintId vec = fromIntegral $ foldl' (\fId x -> fId * 256 + x) 0 xs+  where+    xs = unVector vec++loadSemanticsInstr :: (I i) => Instruction i ()+loadSemanticsInstr = do+  count <- popInstr+  fId <- liftM (fingerprintId . reverseV) $ popVectorInstr count+  mFingerprint <- gets $ Map.lookup fId . getFingerprints+  case mFingerprint of+    Nothing -> reverseInstr+    Just fingerprint -> do+      modify $ withSemantics $ Semantics.pushFingerprint fingerprint+      pushInstr $ fromIntegral fId+      pushInstr 1++unloadSemanticsInstr :: (I i) => Instruction i ()+unloadSemanticsInstr = do+  count <- popInstr+  fId <- liftM (fingerprintId . reverseV) $ popVectorInstr count+  mFingerprint <- gets $ Map.lookup fId . getFingerprints+  case mFingerprint of+    Nothing -> reverseInstr+    Just fingerprint -> modify $ withSemantics $ Semantics.popFingerprint fingerprint++-----------------------------------------------------------+-- Concurrent Funge-98+-----------------------------------------------------------++splitInstr :: (I i) => Instruction i ()+splitInstr = do+  env <- get+  let ip = currentIp env+  case getValidIds env of+    [] -> liftIO $ do+      putStrLn "Cannot create a unique ID for new IP."+      exitFailure+    ident : idents -> let+      newIp = ip { getId = ident, getDelta = negate . getDelta $ ip }+      in modify $ const $ addSpawnedIp newIp $ env { getValidIds = idents }+
+ src/Interpreter.hs view
@@ -0,0 +1,68 @@+module Interpreter (+    runFungi+  ) where++import Control.Arrow ((&&&))+import Control.Monad.State.Strict++import qualified Data.List.Zipper as Zipper++import System.Exit (ExitCode, exitSuccess)++import Env+import Instruction+import Ip++-----------------------------------------------------------++data RunResult i = RunResult {+    getLiveIps :: [Ip Env i]+  , getResultEnv :: Env i+  }++runFungi :: (I i) => Env i -> IO ExitCode+runFungi = evalStateT $ forever runEnvRound++runEnvRound :: (I i) => Instruction i ()+runEnvRound = do+  noIps <- gets $ Zipper.emptyp . getIps+  if noIps+    then liftIO exitSuccess+    else do+      runResult <- runEnvRound'+      let ips = Zipper.fromList $ getLiveIps runResult+      modify $ \env -> env { getIps = ips }+      advanceIps++runEnvRound' :: (I i) => Instruction i (RunResult i)+runEnvRound' = do+  ips <- gets getIps+  case Zipper.safeCursor ips of+    Nothing -> do+      env <- get+      return RunResult {+          getLiveIps = []+        , getResultEnv = env+        }+    Just _ -> do+      runCurrentInstruction+      (ip, spawnedIps) <- gets $ currentIp &&& getSpawnedIps+      let liveIps = spawnedIps ++ [ip | isAlive ip]+      modify $ \env -> withIps Zipper.right env {+          getSpawnedIps = []+        , getValidIds = [getId ip | not $ isAlive ip] ++ getValidIds env+        }+      runResult <- runEnvRound'+      let liveIps' = liveIps ++ getLiveIps runResult+      return runResult { getLiveIps = liveIps' }++advanceIps :: (I i) => Instruction i ()+advanceIps = do+  ips <- gets getIps+  case Zipper.safeCursor ips of+    Nothing -> modify $ withIps Zipper.start+    Just _ -> do+      trampolineInstr+      modify $ withIps Zipper.right+      advanceIps+
+ src/Ip.hs view
@@ -0,0 +1,141 @@+module Ip (+    Ip+  , mkIp++  , getId+  , getPos+  , getDelta+  , getSs+  , isAlive+  , getStorageOffset+  , getSemantics+  , hrtiMark+++  , testMode+  , addMode+  , removeMode+  , toggleMode++  , record+  , clearRecordings+  , getRecordings+  , getRecordLength+  , setRecordLength++  , killIp+  , reverseIp+  , setPos+  , setDelta+  , setSs+  , setStorageOffset++  ) where++import Control.Monad.State.Strict++import Data.Deque+import Data.I+import Data.Map (Map)+import Data.StackSet (StackSet)+import qualified Data.StackSet as StackSet+import Data.Sequence+import qualified Data.Sequence as Seq+import Data.Stack+import Data.Vector++import System.Time (ClockTime)++import Text.PrettyShow++import Mode+import Semantics++-----------------------------------------------------------++type Instruction env i = StateT (env i) IO++data Ip env i = Ip {+    getId :: i+  , getPos :: Vector i+  , getDelta :: Vector i+  , getSs :: Stack (Deque i)+  , isAlive :: Bool+  , getStorageOffset :: !(Vector i)+  , getSemantics :: Semantics env i+  , modes :: StackSet Mode+  , hrtiMark :: Maybe ClockTime+  , getRecordings :: Seq (Instruction env i ())+  , getRecordLength :: i+  }++instance (PrettyShow i) => PrettyShow (Ip env i) where+  pshow ip = concat [ []+    , "(IP"+    , " "+    , "id=" ++ pshow (getId ip)+    , " "+    , "pos=" ++ pshow (getPos ip)+    , " "+    , "delta=" ++ pshow (getDelta ip)+    , " "+    , "modes=" ++ pshow (StackSet.toList $ modes ip)+    , ")"+    ]++mkIp :: (I i) => Int -> i -> Map i (Instruction env i ()) -> Ip env i+mkIp dim ident baseSemantics = Ip {+    getId = ident+  , getPos = takeV dim 0+  , getDelta = takeV dim (1 `cons` 0)+  , getSs = mkStack1 mkDeque+  , isAlive = True+  , getStorageOffset = takeV dim 0+  , getSemantics = mkSemantics baseSemantics+  , modes = StackSet.empty+  , hrtiMark = Nothing+  , getRecordings = Seq.empty+  , getRecordLength = 0+  }++testMode :: Mode -> Ip env i -> Bool+testMode mode = StackSet.member mode . modes++addMode :: Mode -> Ip env i -> Ip env i+addMode mode ip = ip { modes = StackSet.insert mode $ modes ip }++removeMode :: Mode -> Ip env i -> Ip env i+removeMode mode ip = ip { modes = StackSet.delete mode $ modes ip }++toggleMode :: Mode -> Ip env i -> Ip env i+toggleMode mode ip = if testMode mode ip+  then removeMode mode ip+  else addMode mode ip++killIp :: Ip env i -> Ip env i+killIp ip = ip { isAlive = False }++reverseIp :: (Num i) => Ip env i -> Ip env i+reverseIp ip = ip { getDelta = negate . getDelta $ ip }++setPos :: (Num i) => Vector i -> Ip env i -> Ip env i+setPos pos ip = ip { getPos = pos }++setDelta :: (Num i) => Vector i -> Ip env i -> Ip env i+setDelta delta ip = ip { getDelta = delta }++setSs :: Stack (Deque i) -> Ip env i -> Ip env i+setSs s ip = ip { getSs = s }++setStorageOffset :: Vector i -> Ip env i -> Ip env i+setStorageOffset v ip = ip { getStorageOffset = v }++setRecordLength :: i -> Ip env i -> Ip env i+setRecordLength n ip = ip { getRecordLength = n }++clearRecordings :: Ip env i -> Ip env i+clearRecordings ip = ip { getRecordings = Seq.empty }++record :: Instruction env i () -> Ip env i -> Ip env i+record instr ip = ip { getRecordings = getRecordings ip |> instr }+
+ src/Math.hs view
@@ -0,0 +1,24 @@+module Math (+    squareRoot+  ) where++-----------------------------------------------------------++-- The following code was aquired from:+-- http://www.haskell.org/haskellwiki/Generic_number_type#squareRoot++(^!) :: Num a => a -> Int -> a+(^!) x n = x^n+ +squareRoot :: Integer -> Integer+squareRoot 0 = 0+squareRoot 1 = 1+squareRoot n =+   let twopows = iterate (^!2) 2+       (lowerRoot, lowerN) =+          last $ takeWhile ((n>=) . snd) $ zip (1:twopows) twopows+       newtonStep x = div (x + div n x) 2+       iters = iterate newtonStep (squareRoot (div n lowerN) * lowerRoot)+       isRoot r  =  r^!2 <= n && n < (r+1)^!2+   in  head $ dropWhile (not . isRoot) iters+
+ src/Mode.hs view
@@ -0,0 +1,24 @@+module Mode (+    Mode (..)+  ) where++import Text.PrettyShow++-----------------------------------------------------------++data Mode+  = Befunge93+  | Bizarro+  | Hover+  | Invert+  | Learn+  | Record+  | String+  | String93+  | Switch+  | Queue+  deriving (Show, Eq, Ord)++instance PrettyShow Mode where+  pshow = show+
+ src/ProcessArgs.hs view
@@ -0,0 +1,114 @@+module ProcessArgs (+    processArgs+  , ProcessedArgs (..)+  ) where++import Control.Monad++import Data.ByteSize (byteSize)+import Data.Char (toLower)++import Debug.Debugger (DebugMode (..))++import UnknownInstruction++-----------------------------------------------------------++data ProcessedArgs = ProcessedArgs {+    argsHelp :: Bool+  , argsVersion :: Bool+  , argsFingerDoc :: Maybe String+  , argsDebugMode :: DebugMode+  , argsCellByteSize :: Maybe Int+  , argsDim :: Maybe Int+  , argsUnknownMode :: UnknownInstruction+  , argsFile :: Maybe FilePath+  , argsFungeArgs :: [String]+  }+  deriving (Show, Eq, Ord)++defaultProcessedArgs :: ProcessedArgs+defaultProcessedArgs = ProcessedArgs {+    argsHelp = False+  , argsVersion = False+  , argsFingerDoc = Nothing+  , argsDebugMode = DebugOff+  , argsCellByteSize = byteSize (0 :: Int)+  , argsDim = Nothing+  , argsUnknownMode = ReverseUnknown+  , argsFile = Nothing+  , argsFungeArgs = []+  }++processArgs :: [String] -> Maybe ProcessedArgs+processArgs [] = Just defaultProcessedArgs+processArgs (arg:args) = case arg of+  "--help" -> processHelp args+  "-?" -> processHelp args+  "--version" -> processVersion args+  "--finger-doc" -> processFingerDoc args+  "--debug" -> processDebug args+  "-d" -> processDebug args+  "--cell-size" -> processCellSize args+  "-s" -> processCellSize args+  "--dim" -> processDim args+  "-n" -> processDim args+  "--unknown" -> processUknown args+  "-u" -> processUknown args+  _ -> processFile arg args++processHelp :: [String] -> Maybe ProcessedArgs+processHelp args = processArgs args >>= \p -> return p { argsHelp = True }++processVersion :: [String] -> Maybe ProcessedArgs+processVersion args = processArgs args >>= \p -> return p { argsVersion = True }++processFingerDoc :: [String] -> Maybe ProcessedArgs+processFingerDoc [] = Nothing+processFingerDoc (arg:args) = processArgs args >>= \p -> return p { argsFingerDoc = Just arg }++processUknown :: [String] -> Maybe ProcessedArgs+processUknown [] = Nothing+processUknown (arg:args) = case mUnknownMode of+  Nothing -> Nothing+  Just unknownMode -> processArgs args >>= \p -> return p { argsUnknownMode = unknownMode }+  where+    mUnknownMode = case map toLower arg of+      "reverse" -> Just ReverseUnknown+      "fail" -> Just FailUnknown+      "debug" -> Just DebugUnknown+      _ -> Nothing++processDebug :: [String] -> Maybe ProcessedArgs+processDebug [] = processArgs [] >>= \p -> return p { argsDebugMode = DebugStep }+processDebug (arg:args) = case mDebugMode of+  Nothing -> processArgs (arg:args) >>= \p -> return p { argsDebugMode = DebugStep }+  Just debugMode -> processArgs args >>= \p -> return p { argsDebugMode = debugMode }+  where+    mDebugMode = case map toLower arg of+      "0" -> Just DebugOff+      "1" -> Just DebugStep+      "false" -> Just DebugOff+      "true" -> Just DebugStep+      "off" -> Just DebugOff+      "on" -> Just DebugStep+      _ -> Nothing++processDim :: [String] -> Maybe ProcessedArgs+processDim [] = Nothing+processDim (arg:args) = case reads arg of+  [(n, "")] -> processArgs args >>= \p -> return p { argsDim = Just n }+  _ -> Nothing++processCellSize :: [String] -> Maybe ProcessedArgs+processCellSize [] = Nothing+processCellSize (arg:args) = case reads arg of+  [(n, "")] -> processArgs args >>= \p -> return p { argsCellByteSize = guard (n > 0) >> Just n }+  _ -> Nothing++processFile :: FilePath -> [String] -> Maybe ProcessedArgs+processFile file args = processArgs [] >>= \p -> return p {+    argsFile = Just file+  , argsFungeArgs = args+  }+
+ src/Random.hs view
@@ -0,0 +1,48 @@+module Random (
+    Random (..)
+  ) where
+
+import Control.Monad
+
+import Data.Int
+
+import System.Random.MWC (GenIO, Variate)
+import qualified System.Random.MWC as MWC
+
+-----------------------------------------------------------
+
+class Random a where
+  uniformR :: (a, a) -> IO a
+
+-----------------------------------------------------------
+
+uniformR' :: Variate a => (a, a) -> GenIO -> IO a
+uniformR' = MWC.uniformR
+
+uniformRIO :: Variate a => (a, a) -> IO a
+uniformRIO = MWC.withSystemRandom . uniformR'
+
+mapPair :: (a -> b) -> (a, a) -> (b, b)
+mapPair f (x, y) = (f x, f y)
+
+fromInt64 :: Int64 -> Integer
+fromInt64 = fromIntegral
+
+instance Random Integer where
+  uniformR = liftM fromInt64 . uniformRIO . mapPair fromInteger
+
+instance Random Int where
+  uniformR = uniformRIO
+
+instance Random Int8 where
+  uniformR = uniformRIO
+
+instance Random Int16 where
+  uniformR = uniformRIO
+
+instance Random Int32 where
+  uniformR = uniformRIO
+
+instance Random Int64 where
+  uniformR = uniformRIO
+
+ src/Semantics.hs view
@@ -0,0 +1,135 @@+module Semantics (+    Semantics+  , mkSemantics+  , lookup+  , lookupBase+  , lookupFinger+  , lookupOverlay+  , pushFingerprint+  , popFingerprint+  , toggleOverlay+  , addOverlay+  , removeOverlay+  ) where++import Prelude hiding (lookup)++import Control.Monad.State.Strict++import Data.Char (ord)+import Data.I+import Data.Labeled+import Data.Map (Map)+import qualified Data.Map as Map++import Mode++-----------------------------------------------------------++type Instruction env i = StateT (env i) IO++type InfMap k v = (k -> Maybe v, Map k (Maybe v))++-----------------------------------------------------------++data Semantics env i = S {+    baseInstrs :: Map i (Instruction env i ())+  , fingerInstrs :: Map i [Instruction env i ()]+  , overlayInstrs :: [Labeled Mode (InfMap i (Instruction env i ()))]+  }++mkSemantics :: (I i) => Map i (Instruction env i ()) -> Semantics env i+mkSemantics base = S {+    baseInstrs = base+  , fingerInstrs = Map.fromList $ zip [fromIntegral $ ord c | c <- ['A'..'Z']] $ repeat []+  , overlayInstrs = []+  }++lookup :: (I i) => i -> Semantics env i -> Maybe (Instruction env i ())+lookup i sem = case lookupOverlay i sem of+  Just instr -> Just instr+  Nothing -> case lookupFinger i sem of+    Just instr -> Just instr+    Nothing -> lookupBase i sem++lookupOverlay :: (I i) => i -> Semantics env i -> Maybe (Instruction env i ())+lookupOverlay i = lookupOverlay' i . map unlabel . overlayInstrs++lookupFinger :: (I i) => i -> Semantics env i -> Maybe (Instruction env i ())+lookupFinger i = lookupFinger' i . fingerInstrs++lookupBase :: (I i) => i -> Semantics env i -> Maybe (Instruction env i ())+lookupBase i = lookupBase' i . baseInstrs++lookupOverlay' :: (I i) => i -> [InfMap i (Instruction env i ())] -> Maybe (Instruction env i ())+lookupOverlay' _ [] = Nothing+lookupOverlay' i ((f, m) : ms) = case Map.lookup i m of+  Just mInstr -> case mInstr of+    Just instr -> Just instr+    Nothing -> lookupOverlay' i ms+  Nothing -> case f i of+    Just instr -> Just instr+    Nothing -> lookupOverlay' i ms++lookupFinger' :: (I i) => i -> Map i [Instruction env i ()] -> Maybe (Instruction env i ())+lookupFinger' i m = case Map.lookup i m of+  Nothing -> Nothing+  Just [] -> Nothing+  Just (instr:_) -> Just instr++lookupBase' :: (I i) => i -> Map i (Instruction env i ()) -> Maybe (Instruction env i ())+lookupBase' = Map.lookup++pushFingerprint :: (I i) => [(i, Instruction env i ())] -> Semantics env i -> Semantics env i+pushFingerprint assocs sem = sem { fingerInstrs = m' }+  where+    m = fingerInstrs sem+    m' = foldr add m assocs+    add (i, instr) = Map.adjust (instr:) i++popFingerprint :: (I i) => [(i, Instruction env i ())] -> Semantics env i -> Semantics env i+popFingerprint assocs sem = sem { fingerInstrs = m' }+  where+    m = fingerInstrs sem+    m' = foldr (remove . fst) m assocs+    remove = Map.adjust tail++addOverlay :: (I i)+        => Mode+        -> (i -> Maybe (Instruction env i ()), Map i (Maybe (Instruction env i ())))+        -> Semantics env i+        -> Semantics env i+addOverlay mode f_m sem = if mode `elem` map getLabel (overlayInstrs sem)+  then sem+  else addOverlay' mode f_m sem++addOverlay' :: (I i)+        => Mode+        -> (i -> Maybe (Instruction env i ()), Map i (Maybe (Instruction env i ())))+        -> Semantics env i+        -> Semantics env i+addOverlay' mode f_m sem = sem { overlayInstrs = imap : overlayInstrs sem }+  where+    imap = label mode f_m++removeOverlay :: (I i) => Mode -> Semantics env i -> Semantics env i+removeOverlay mode sem = sem { overlayInstrs = removeOverlay' mode $ overlayInstrs sem }++removeOverlay' :: (I i)+        => Mode+        -> [Labeled Mode (InfMap i (Instruction env i ()))]+        -> [Labeled Mode (InfMap i (Instruction env i ()))]+removeOverlay' _ [] = []+removeOverlay' mode (m:ms) = if getLabel m == mode+  then ms+  else m : removeOverlay' mode ms++toggleOverlay :: (I i)+        => Mode+        -> (i -> Maybe (Instruction env i ()), Map i (Maybe (Instruction env i ())))+        -> Semantics env i+        -> Semantics env i+toggleOverlay mode f_m sem = if mode `elem` map getLabel (overlayInstrs sem)+  then removeOverlay mode sem+  else addOverlay' mode f_m sem+
+ src/Space/Cell.hs view
@@ -0,0 +1,49 @@+module Space.Cell (+    Cell+  , chrCell+  , ordCell+  , cellToChar+  , cellToPrintableChar+  , charToCell+  ) where++import Data.Char (chr, ord, isPrint)++import Text.PrettyShow++-----------------------------------------------------------++newtype Cell i = Cell { unCell :: i }+  deriving (Show, Eq, Ord)++instance (Show i, Integral i) => PrettyShow (Cell i) where+  pshow cell = concat [ ""+    , "(Cell "+    , maybe "'\\???'" show . cellToChar $ cell+    , " "+    , show . ordCell $ cell+    , ")"+    ]++chrCell :: i -> Cell i+chrCell = Cell++ordCell :: Cell i -> i+ordCell = unCell++cellToChar :: (Integral i) => Cell i -> Maybe Char+cellToChar (Cell n) = if minB <= n && n <= maxB+  then Just . chr $ fromIntegral n+  else Nothing+  where+    minB = fromIntegral . ord $ minBound+    maxB = fromIntegral . ord $ maxBound++cellToPrintableChar :: (Integral i) => Cell i -> Maybe Char+cellToPrintableChar cell = cellToChar cell >>= \c -> if isPrint c+  then Just c+  else Nothing++charToCell :: (Num i) => Char -> Cell i+charToCell = Cell . fromIntegral . ord+
+ src/Space/Space.hs view
@@ -0,0 +1,162 @@+module Space.Space (+    Space+  , mkSpace+  , cellAt+  , putCell+  , travelBy+  , minMaxCoords+  , putSpaceAt+  , inBounds+  ) where++import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as BS+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Vector++import Space.Cell++import Text.PrettyShow++-----------------------------------------------------------++data Conservative a = Precise !a | Imprecise !a+  deriving (Show, Eq, Ord)++isPrecise :: Conservative a -> Bool+isPrecise (Precise _) = True+isPrecise _ = False++toImprecise :: Conservative a -> Conservative a+toImprecise (Precise x) = Imprecise x+toImprecise c = c++conservativeVal :: Conservative a -> a+conservativeVal (Precise x) = x+conservativeVal (Imprecise x) = x++instance Functor Conservative where+  fmap f (Precise x) = Precise $ f x+  fmap f (Imprecise x) = Imprecise $ f x++instance (PrettyShow a) => PrettyShow (Conservative a) where+  pshow (Precise x) = "Precise " ++ pshow x+  pshow (Imprecise x) = "Imprecise" ++ pshow x++-----------------------------------------------------------++type CellMap i = Map [i] (Cell i)++data Space i = Space {+    spaceMap :: CellMap i+  , spaceDim :: Int+  , conservativeMinMaxCoords :: !(Conservative (Vector i, Vector i))+  }+  deriving (Show, Eq)++instance (PrettyShow i, Show i, Integral i) => PrettyShow (Space i) where+  pshow s = concat [ []+    , "(Space"+    , " "+    , "(min,max)=" ++ pshow (conservativeMinMaxCoords s)+    , " "+    , "assocs=" ++ pshow (Map.assocs . spaceMap $ s)+    , ")"+    ]++mkSpace :: (Integral i) => Int -> ByteString -> Space i+mkSpace dim str+  | dim <= 0  = error "Space.Space.mkSpace given a non-positive dimension"+  | otherwise = case BS.foldl' f (0, 0, 0, space, '\0') str of+      (_, _, _, s, _) -> s+  where+    origin = mkVector $ replicate dim 0+    space = Space {+        spaceMap = Map.empty+      , spaceDim = dim+      , conservativeMinMaxCoords = Precise (origin, origin)+      }+    f (x, y, z, s, p) c = case c of+      ' ' -> (x + 1, y, z, s, c)+      '\r'-> guardDim 2 (0, y + 1, z, s, c)+      '\n'-> guardDim 2 $ if p == '\r'+        then (x, y, z, s, c)+        else (0, y + 1, z, s, c)+      '\f'-> guardDim 3 (0, 0, z + 1, s, c)+      _   -> let+        v = take dim $ [x, y, z] ++ repeat 0+        s' = putCell s (charToCell c) $ mkVector v+        in (x + 1, y, z, s', c)+      where+        guardDim n t = if dim >= n+          then t+          else (x, y, z, s, c)++cellAt :: (Integral i) => Space i -> Vector i -> Cell i+cellAt s pos = Map.findWithDefault (charToCell ' ') (unVector pos) $ spaceMap s++updateMinMaxCoords :: (Ord i) => (Vector i, Vector i) -> Vector i -> (Vector i, Vector i)+updateMinMaxCoords (minPos, maxPos) pos = (zipWithV min minPos pos, zipWithV max maxPos pos)++putCell :: (Num i, Ord i) => Space i -> Cell i -> Vector i -> Space i+putCell s c pos+  | charToCell ' ' == c = if strictInBounds s pos+    then s {+        spaceMap = Map.delete (unVector pos) m+      }+    else if inBounds s pos+      then s {+          spaceMap = Map.delete (unVector pos) m+        , conservativeMinMaxCoords = toImprecise $ conservativeMinMaxCoords s+        }+      else s+  | otherwise = s {+        spaceMap = Map.insert (unVector pos) c m+      , conservativeMinMaxCoords = fmap (`updateMinMaxCoords` pos) $ conservativeMinMaxCoords s+      }+  where+    m = spaceMap s++inBounds :: (Ord i) => Space i -> Vector i -> Bool+inBounds s pos = minPos <=~ pos && pos <=~ maxPos+  where+    (<=~) = liftOrd (<=)+    (minPos, maxPos) = conservativeVal $ conservativeMinMaxCoords s++strictInBounds :: (Ord i) => Space i -> Vector i -> Bool+strictInBounds s pos = minPos <~ pos && pos <~ maxPos+  where+    (<~) = liftOrd (<)+    (minPos, maxPos) = conservativeVal $ conservativeMinMaxCoords s++travelBy :: (Integral i) => Vector i -> Vector i -> Space i -> Vector i+(pos `travelBy` delta) s = if inBounds s pos'+  then pos'+  else wrap pos delta s+  where+    dim = spaceDim s+    pos' = takeV dim (pos + delta)++wrap :: (Integral i) => Vector i -> Vector i -> Space i -> Vector i+wrap pos delta s = (delta +) . head . dropWhile (inBounds s) . iterate (subtract delta) $ pos++minMaxCoords :: (Integral i) => Space i -> (Vector i, Vector i, Space i)+minMaxCoords s = if isPrecise $ conservativeMinMaxCoords s+  then (cMinPos, cMaxPos, s)+  else case Map.lookup (unVector cMinPos) m >> Map.lookup (unVector cMaxPos) m of+    Just _ -> (cMinPos, cMaxPos, s)+    Nothing -> let+      (minPos, maxPos) = Map.foldWithKey f (0, 0) $ spaceMap s+      f k _ z = updateMinMaxCoords z $ mkVector k+      s' = s { conservativeMinMaxCoords = Precise (minPos, maxPos) }+      in (minPos, maxPos, s')+  where+    m = spaceMap s+    (cMinPos, cMaxPos) = conservativeVal $ conservativeMinMaxCoords s++putSpaceAt :: (Integral i) => Vector i -> Space i -> Space i -> Space i+putSpaceAt pos baseSpace = Map.foldWithKey f baseSpace . spaceMap+  where+    f pos' cell space = putCell space cell (pos + mkVector pos')+
+ src/System/IO/Buffering.hs view
@@ -0,0 +1,17 @@+module System.IO.Buffering (+    withBuffering+  , BufferMode (..)+  ) where++import System.IO++-----------------------------------------------------------++withBuffering :: BufferMode -> Handle -> (Handle -> IO a) -> IO a+withBuffering buff hdl io = do+  origBuff <- hGetBuffering hdl+  hSetBuffering hdl buff+  res <- io hdl+  hSetBuffering hdl origBuff+  return res+
+ src/Text/Help/Debug.hs view
@@ -0,0 +1,52 @@+module Text.Help.Debug (+    help+  ) where++import Text.PrintOption++-----------------------------------------------------------++p :: Char -> String -> String -> IO ()+p = printOption++help :: IO ()+help = do+  putStrLn "Note: Help commands do not need '-' characters in front of them."+  putStrLn "Values of the form POS are space separated numbers."+  putStrLn "Values of the form VALS are space separated VAL constructs."+  putStrLn "Values of the form VAL can be any one of the following:"+  putStrLn "    - A number."+  putStrLn "    - A single non-quote character."+  putStrLn "    - A quoted set of characters. Single and double quotes allowed."+  putStrLn "-----------------------------------------------------------"+  p '?' "help" "Displays this message."+  p ' ' "exit" "Exit the program."+  p ' ' "quit" "Same as 'exit'."+  p ' ' "back [N=1]" "Enable step mode and try to move back in time N interpreter rounds."+  p ' ' "break POS" "Create a breakpoint at POS."+  p ' ' "breaks" "Display all registered breakpoints."+  p ' ' "cell" "Display the current cell."+  p ' ' "cellat POS" "Display the cell at POS."+  p ' ' "clear POS" "Remove breakpoint at POS."+  p ' ' "clear *" "Remove all breakpoints"+  p ' ' "continue" "Disable step mode."+  p ' ' "dim" "Dispay the funge space dimensions."+  p ' ' "ip" "Dispay the current ip"+  p ' ' "locale XRAD YRAD" "Display the area around the current ip. Only shows cells in the X-Y plane."+  p ' ' "locale RAD" "Same as 'locale RAD RAD'."+  p ' ' "locale" "Same as 'locale XRAD YRAD', where XRAD and YRAD can be set using 'setlocale'."+  p ' ' "nodebug" "Turn off the debugger."+  p ' ' "pop N" "Pops the top N values off the TOSS."+  p ' ' "push VALS" "Push VALS onto the stack. VAL's toward the right are pushed first."+  p ' ' "record N" "Guarantees that 'back' can go back M time steps, provided M <= N and M rounds have passed since 'record N' was invoked."+  p ' ' "setpos POS" "Set the position of the current ip to POS."+  p ' ' "space" "Lists more information that you want to know about the funge space. Warning: This will list every cell and its position."+  p ' ' "s" "Show the TOSS of the current ip."+  p ' ' "setlocale XRAD YRAD" "Defaults the radii displayed by 'locale' to XRAD and YRAD."+  p ' ' "ss" "Show the stack stack of the current ip."+  p ' ' "step" "Enable step mode."+  p ' ' "unshowable CHAR" "Makes the debugger display CHAR for unshowable cells in 'locale'. By default, '®' is used."+  p ' ' "unwatch VALS" "Remove any watchpoints that watch VALS."+  p ' ' "watch VALS" "Creates a watchpoint that watches VALS. Causes the debugger to break when the top of the TOSS is VALS. Left VAL's correspond to top stack values."+  p ' ' "watches" "Display all watch points."+
+ src/Text/Help/Fingerprint.hs view
@@ -0,0 +1,74 @@+module Text.Help.Fingerprint (+    help+  ) where++import qualified Data.Map as Map+import Data.Maybe (fromMaybe)++import qualified Fingerprint.BASE as BASE+import qualified Fingerprint.BF93 as BF93+import qualified Fingerprint.BOOL as BOOL+import qualified Fingerprint.BZRO as BZRO+import qualified Fingerprint.CPLI as CPLI+import qualified Fingerprint.FIXP as FIXP+import qualified Fingerprint.HRTI as HRTI+import qualified Fingerprint.MODE as MODE+import qualified Fingerprint.MODU as MODU+import qualified Fingerprint.NOP  as NOP+import qualified Fingerprint.NULL as NULL+import qualified Fingerprint.ORTH as ORTH+import qualified Fingerprint.RECD as RECD+import qualified Fingerprint.REFC as REFC+import qualified Fingerprint.ROMA as ROMA+import qualified Fingerprint.STRN as STRN++import qualified Text.Help.Fingerprint.BASE as H_BASE+import qualified Text.Help.Fingerprint.BF93 as H_BF93+import qualified Text.Help.Fingerprint.BOOL as H_BOOL+import qualified Text.Help.Fingerprint.BZRO as H_BZRO+import qualified Text.Help.Fingerprint.CPLI as H_CPLI+import qualified Text.Help.Fingerprint.FIXP as H_FIXP+import qualified Text.Help.Fingerprint.HRTI as H_HRTI+import qualified Text.Help.Fingerprint.MODE as H_MODE+import qualified Text.Help.Fingerprint.MODU as H_MODU+import qualified Text.Help.Fingerprint.NOP  as H_NOP+import qualified Text.Help.Fingerprint.NULL as H_NULL+import qualified Text.Help.Fingerprint.ORTH as H_ORTH+import qualified Text.Help.Fingerprint.RECD as H_RECD+import qualified Text.Help.Fingerprint.REFC as H_REFC+import qualified Text.Help.Fingerprint.ROMA as H_ROMA+import qualified Text.Help.Fingerprint.STRN as H_STRN++-----------------------------------------------------------++line :: IO ()+line = putStrLn $ replicate 80 '-'++noHelp :: String -> IO ()+noHelp finger = putStrLn $ "Unable to find fingerprint documentation for " ++ finger++help :: String -> IO ()+help finger = do+  line+  doc+  line+  where+    doc = fromMaybe (noHelp finger) $ Map.lookup finger $ Map.fromList [+        (BASE.name, H_BASE.help)+      , (BF93.name, H_BF93.help)+      , (BOOL.name, H_BOOL.help)+      , (BZRO.name, H_BZRO.help)+      , (CPLI.name, H_CPLI.help)+      , (FIXP.name, H_FIXP.help)+      , (HRTI.name, H_HRTI.help)+      , (MODE.name, H_MODE.help)+      , (MODU.name, H_MODU.help)+      , (NOP.name , H_NOP.help )+      , (NULL.name, H_NULL.help)+      , (ORTH.name, H_ORTH.help)+      , (RECD.name, H_RECD.help)+      , (REFC.name, H_REFC.help)+      , (ROMA.name, H_ROMA.help)+      , (STRN.name, H_STRN.help)+      ]+
+ src/Text/Help/Fingerprint/BASE.hs view
@@ -0,0 +1,19 @@+module Text.Help.Fingerprint.BASE (+    help+  ) where++import Text.PrintOption++-----------------------------------------------------------++p :: Char -> String -> IO ()+p c = printOption ' ' $ " " ++ [c] ++ " --"++help :: IO ()+help = do+  p 'B' "Pop X. Output X in base 2 followed by a space."+  p 'H' "Pop X. Output X in base 16 followed by a space."+  p 'I' "Pop N. Read input in base N."+  p 'N' "Pop X. Pop N. Output X in base N followed by a space."+  p 'O' "Pop X. Output X in base 8 followed by a space."+
+ src/Text/Help/Fingerprint/BF93.hs view
@@ -0,0 +1,33 @@+module Text.Help.Fingerprint.BF93 (+    help+  ) where++import Data.List (intercalate)++import Text.PrintOption++-----------------------------------------------------------++p :: Char -> String -> IO ()+p c = printOption ' ' $ " " ++ [c] ++ " --"++maxWidth :: Int+maxWidth = 80++line :: IO ()+line = putStrLn $ replicate maxWidth '-'++help :: IO ()+help = do+  p 'B' "Toggle Befunge93 mode."+  line+  putStrLn "\n ** BEFUNGE93 MODE **\n"+  putStrLn "In Befunge93 mode, the following instructins take on new meaning: "+  p '"' $ "Toggle String93 mode. Like ordinary String mode, except contiguous spaces are not"+    ++ " collapsed. Instead, each space is pushed onto the stack."+  p '@' $ "Exit the program with exit code 0 regardless of the number of live IPs in the program."+  putStrLn $ fit maxWidth $ "In addition, the following instructions behave as the base Funge-98 instructions:\n"+    ++ (intercalate ", " $ map (\c -> '(' : c : ")") " +-*/%!`><^v?_|:\\$.,#gp&~") ++ ".\n"+    ++ "Every other instruction reflects. Thus there is no way for an IP to leave Befunge93 mode"+    ++ " via the BF93 fingerprint."+
+ src/Text/Help/Fingerprint/BOOL.hs view
@@ -0,0 +1,18 @@+module Text.Help.Fingerprint.BOOL (+    help+  ) where++import Text.PrintOption++-----------------------------------------------------------++p :: Char -> String -> IO ()+p c = printOption ' ' $ " " ++ [c] ++ " --"++help :: IO ()+help = do+  p 'A' "Pop Y. Pop X. Push 0 if X is 0. Else push Y."+  p 'N' "Pop X. Push 1 if X is 0. Else push 0."+  p 'O' "Pop Y. Pop X. Push X if X is not 0. Else push Y."+  p 'X' "Pop Y. Pop X. Push 1 if X is 0 and Y not 0 or if X is not 0 and Y is 0. Else push 1."+
+ src/Text/Help/Fingerprint/BZRO.hs view
@@ -0,0 +1,79 @@+module Text.Help.Fingerprint.BZRO (+    help+  ) where++import Text.PrintOption++-----------------------------------------------------------++p :: Char -> String -> IO ()+p c = printOption ' ' $ " " ++ [c] ++ " --"++maxWidth :: Int+maxWidth = 80++line :: IO ()+line = putStrLn $ replicate maxWidth '-'++correspondences :: [(Char, Char)]+correspondences = [+    ('>', '<')+  , ('<', '>')+  , ('^', 'v')+  , ('v', '^')+  , ('h', 'l')+  , ('l', 'h')+  , ('[', ']')+  , (']', '[')+  , ('_', '|')+  , ('|', '_')+  , ('(', ')')+  , (')', '(')+  , ('{', '}')+  , ('}', '{')+  , ('+', '-')+  , ('-', '+')+  , ('*', '/')+  , ('/', '*')+  , ('i', 'o')+  , ('o', 'i')+  , ('&', '.')+  , ('.', '&')+  , ('~', ',')+  , (',', '~')+  , ('g', 'p')+  , ('p', 'g')+  , ('@', 'q')+  , ('q', '@')+  , ('\'','"')+  , ('"','\'')+  ] ++ zip nums (reverse nums) ++ zip alphas (reverse alphas)+  where+    nums = "0123456789abcdef"+    alphas = ['A'..'Z']++help :: IO ()+help = do+  p 'B' "Toggle Bizarro mode."+  line+  putStrLn "\n ** BIZARRO MODE **\n"+  putStrLn $ fit maxWidth $ "In Bizarro mode, the following instructions on the left correspond to the corresponding"+    ++ " instruction on the right as if Bizarro mode were not on:\n"+  mapM_ (\(x, y) -> putStrLn $ "            " ++ [x] ++ "    --->    " ++ [y]) correspondences+  putStrLn ""+  putStrLn $ fit maxWidth $ "Note that if Bizarro mode is on, a (Y) instruction will"+    ++ " turn off Bizarro mode and (B) will not due to (Y) corresponding to (B) and vice-versa."+    ++ " Also note that the corresponding instructions are not necessarily the base Funge-98"+    ++ " instructions. For example, if Hover mode is and was enabled before Bizarro mode (see MODE fingerprint"+    ++ " for details on Hover mode), (<) will add 1 the IP's first delta coordinate"+    ++ " instead of setting the IP's delta to east (or west for that matter)."+    ++ " As with all modes, the most recent mode has priority. As an example, if Hover mode"+    ++ " is enabled after and while Bizarro mode is enabled, (<) will subtract 1 from the IP's first delta"+    ++ " coordinate. To alleviate any confusion about String mode, if String mode is enabled during Bizarro"+    ++ " mode, a (') instruction will push 39 onto the stack, and (\") will disable String mode despite the"+    ++ " fact that (') turns on String mode when Bizarro mode is on."+  putStrLn $ fit maxWidth $ "\nAll the clarifications above are not special rules. The only rule is that the"+    ++ " instructions correspond to other instructions based on symbols, not on semantics. The clarifications"+    ++ " assume 'usual' Bizarro mode circumstances, meaning some other mode or instruction is not radically"+    ++ " changing the behavior of Bizarro mode, other modes, instructions, and/or the interpreter."+
+ src/Text/Help/Fingerprint/CPLI.hs view
@@ -0,0 +1,20 @@+module Text.Help.Fingerprint.CPLI (+    help+  ) where++import Text.PrintOption++-----------------------------------------------------------++p :: Char -> String -> IO ()+p c = printOption ' ' $ " " ++ [c] ++ " --"++help :: IO ()+help = do+  p 'A' "Pop A. Pop B. Pop C. Pop D. Let E+Fi be the complex number (A+Bi)+(C+Di). Push E. Push F."+  p 'D' "Pop A. Pop B. Pop C. Pop D. Let E+Fi be the complex number (A+Bi)/(C+Di). Push E. Push F."+  p 'M' "Pop A. Pop B. Pop C. Pop D. Let E+Fi be the complex number (A+Bi)*(C+Di). Push E. Push F."+  p 'O' "Pop A. Pop B. Output the complex number (A+Bi) followed by a space."+  p 'S' "Pop A. Pop B. Pop C. Pop D. Let E+Fi be the complex number (A+Bi)-(C+Di). Push E. Push F."+  p 'V' "Pop A. Pop B. Push |A+Bi|. Note |A+Bi| = sqrt(A^2+B^2)."+
+ src/Text/Help/Fingerprint/FIXP.hs view
@@ -0,0 +1,30 @@+module Text.Help.Fingerprint.FIXP (+    help+  ) where++import Text.PrintOption++-----------------------------------------------------------++p :: Char -> String -> IO ()+p c = printOption ' ' $ " " ++ [c] ++ " --"++help :: IO ()+help = do+  p 'A' "Pop Y. Pop X. Push the bitwise AND of X and Y."+  p 'B' "Pop X. Push 10000*acos(X/10000). Angle is measured in degrees."+  p 'C' "Pop X. Push 10000*cos(X/10000). Angle is measured in degrees."+  p 'D' "Pop N. Let X be a random number be chosen uniformly from [0, |N|]. If X >= 0 then push N. Else push -N."+  p 'I' "Pop X. Push 10000*sin(X/10000). Angle is measured in degrees."+  p 'J' "Pop X. Push 10000*asin(X/10000). Angle is measured in degrees."+  p 'N' "Pop X. Push -X."+  p 'O' "Pop Y. Pop X. Push the bitwise OR of X and Y."+  p 'P' "Pop X. Push X*pi."+  p 'Q' "Pop X. If X >= 0 then push sqrt(X). Else push X."+  p 'R' "Pop Y. Pop X. Push X^B."+  p 'S' "Pop X. If X > 0 then push 1. If X < 0 then push -1. Else push 0."+  p 'T' "Pop X. Push 10000*tan(X/10000). Angle is measured in degrees."+  p 'U' "Pop X. Push 10000*atan(X/10000). Angle is measured in degrees."+  p 'V' "Pop X. Push |X|."+  p 'X' "Pop Y. Pop X. Push the bitwise XOR of X and Y."+
+ src/Text/Help/Fingerprint/HRTI.hs view
@@ -0,0 +1,21 @@+module Text.Help.Fingerprint.HRTI (+    help+  ) where++import Text.PrintOption++-----------------------------------------------------------++p :: Char -> String -> IO ()+p c = printOption ' ' $ " " ++ [c] ++ " --"++help :: IO ()+help = do+  p 'G' $ "Push the smallest clock tick the underlying system can reliably handle, measured in microseconds."+    ++ " Results may vary from call to call."+  p 'M' "Mark the current IP with a timestamp of the current time."+  p 'T' $ "If the current IP has been marked by 'M', push the number of microseconds between the current"+    ++ " time and the marked time. Otherwise reverse the IP."+  p 'E' "If the current IP has been marked by 'M', remove the mark."+  p 'S' "Push the number of microseconds since the last whole second."+
+ src/Text/Help/Fingerprint/MODE.hs view
@@ -0,0 +1,18 @@+module Text.Help.Fingerprint.MODE (+    help+  ) where++import Text.PrintOption++-----------------------------------------------------------++p :: Char -> String -> IO ()+p c = printOption ' ' $ " " ++ [c] ++ " --"++help :: IO ()+help = do+  p 'H' "Toggle Hover mode for the current IP. In Hover mode, the instructions '>', '<', '^', 'v', '|', and '_' treat the IP's delta relatively. That is, instead of setting its dx to 1 and the rest of its delta to 0, '>' would instead simply add 1 to its dx."+  p 'I' "Toggle Invert mode for the current IP. When Invert mode is active, cells are pushed on the stack onto the bottom instead of the top."+  p 'Q' "Toggle Queue mode for the current IP. When Queue mode is active, cells are popped off the stack from the bottom instead of the top."+  p 'S' "Toggle Switch mode. In Switch mode, the pairs of instructions '[' and ']', '{' and '}', and '(' and ')' are treated as switches. When one is executed, the cell it is located in is immediately overwritten with the other instruction of the pair, providing a switching mechanism and a way to seperate coincident IPs."+
+ src/Text/Help/Fingerprint/MODU.hs view
@@ -0,0 +1,19 @@+module Text.Help.Fingerprint.MODU (+    help+  ) where++import Text.PrintOption++-----------------------------------------------------------++p :: Char -> String -> IO ()+p c = printOption ' ' $ " " ++ [c] ++ " --"++help :: IO ()+help = do+  p 'M' $ "Pop Y. Pop X. Push the integer remainder, satisfying [(X `quot` Y)*Y + (X `rem` Y) == X],"+    ++ " where quot is integer division truncated toward zero."+  p 'U' "Same as 'M', but the pushes the absolute value of the result instead of its signed value."+  p 'R' $ "Pop Y. Pop X. Push the integer modulus, satisfying [(X `div` Y)*Y + (X `mod` Y) == X],"+    ++ " where div is integer division truncated toward negative infinity."+
+ src/Text/Help/Fingerprint/NOP.hs view
@@ -0,0 +1,14 @@+module Text.Help.Fingerprint.NOP (+    help+  ) where++import Text.PrintOption++-----------------------------------------------------------++p :: Char -> String -> IO ()+p c = printOption ' ' $ " " ++ [c] ++ " --"++help :: IO ()+help = mapM_ (flip p "Does nothing. Like the 'z' instruction.") ['A'..'Z']+
+ src/Text/Help/Fingerprint/NULL.hs view
@@ -0,0 +1,14 @@+module Text.Help.Fingerprint.NULL (+    help+  ) where++import Text.PrintOption++-----------------------------------------------------------++p :: Char -> String -> IO ()+p c = printOption ' ' $ " " ++ [c] ++ " --"++help :: IO ()+help = mapM_ (flip p "Reverse the IP's delta. Like the 'r' instruction.") ['A'..'Z']+
+ src/Text/Help/Fingerprint/ORTH.hs view
@@ -0,0 +1,28 @@+module Text.Help.Fingerprint.ORTH (+    help+  ) where++import Text.PrintOption++-----------------------------------------------------------++p :: Char -> String -> IO ()+p c = printOption ' ' $ " " ++ [c] ++ " --"++help :: IO ()+help = do+  p 'A' "Pop Y. Pop X. Push the bitwise AND of X and Y."+  p 'O' "Pop Y. Pop X. Push the bitwise OR of X and Y."+  p 'E' "Pop Y. Pop X. Push the bitwise XOR of X and Y."+  p 'X' "Pop X. Set the IP's position's x coordinate to X."+  p 'Y' "Pop Y. Set the IP's position's y coordinate to Y."+  p 'V' "Pop X. Set the IP's dx to X."+  p 'W' "Pop Y. Set the IP's dy to Y."+  p 'G' $ "If the dimension < 2 then reverse. Otherwise do the following: Pop Y. Pop X. Retrieve the value in"+    ++ " funge space at the coordinates (X,Y). Push that value. If the dimension > 2, then the higher"+    ++ " dimension coordinates are 0."+  p 'P' $ "If the dimension < 2 then reverse. Otherwise do the following: Pop Y. Pop X. Pop V. Place the value V in"+    ++ " funge space at the coordinates (X,Y). If the dimension > 2, then the higher dimension coordinates are 0."+  p 'Z' "Pop X. If X = 0, then trampoline (as in a '#' instruction). Else do nothing (as in a 'z' instruction)."+  p 'S' "Output a 0 terminated string: Pop X. If X = 0 then do nothing. Else output X as a character and repeat."+
+ src/Text/Help/Fingerprint/RECD.hs view
@@ -0,0 +1,48 @@+module Text.Help.Fingerprint.RECD (+    help+  ) where++import Text.PrintOption++-----------------------------------------------------------++p :: Char -> String -> IO ()+p c = printOption ' ' $ " " ++ [c] ++ " --"++maxWidth :: Int+maxWidth = 80++line :: IO ()+line = putStrLn $ replicate maxWidth '-'++help :: IO ()+help = do+  p 'C' "Clear all recordings from the current IP."+  p 'N' "Push the length of the current IP's recordings."+  p 'L' $ "Toggle Learn mode. If Learn mode was on and turns off, the number of additional recorded instructions"+    ++ " is pushed onto the stack."+  p 'R' $ "Toggle Record mode. If Record mode was on and turns off, the number of additional recorded instructions"+    ++ " is pushed onto the stack."+  p 'Q' $ "Pop P. Pop N. Let L = the length of the current IP's recordings. If N < 0 or P > L, do nothing."+    ++ " Otherwise select the IP's first min(N,L-P) recorded instructions after dropping max(P,0) of them and"+    ++ " execute them by the current IP. The IP does not automatically advance between"+    ++ " any of the executed instructions. The (Q) instruction takes a single tick."+  p 'P' $ "Pop P. Pop N. Let L = the length of the current IP's recordings. If N < 0 or P > L, do nothing."+    ++ " Otherwise select the IP's first min(N,L-P) recorded instructions after dropping max(P,0) of them and"+    ++ " execute them by the current IP. In between each executed instruction, the IP advances automatically."+    ++ " The phrase 'In between' should be taken literally, for the IP does not automatically advance after the last"+    ++ " executed instruction. That being said, the IP naturally advances after the (P) instruction completes."+    ++ " The (P) instruction takes a single tick."+  line+  putStrLn "\n ** LEARN MODE **\n"+  putStrLn $ fit maxWidth $ "While in Learn mode, all the RECD instructions except (N) and (L) act as if they reflect."+    ++ " Instead of executing the current instruction, the IP records the instruction. Circumstantial data, such"+    ++ " as the IP's state (stack, position, modes, delta, etc.), are not recorded. These recordings are appended"+    ++ " to previous recordings, if any. Learn mode and Record mode share recordings."+  line+  putStrLn "\n ** Record MODE **\n"+  putStrLn $ fit maxWidth $ "While in Record mode, all the RECD instructions except (N) and (R) act as if they reflect."+    ++ " In addition to executing the current instruction, the IP records the instruction. Circumstantial data, such"+    ++ " as the IP's state (stack, position, modes, delta, etc.), are not recorded. These recordings are appended"+    ++ " to previous recordings, if any. Learn mode and Record mode share recordings."+
+ src/Text/Help/Fingerprint/REFC.hs view
@@ -0,0 +1,35 @@+module Text.Help.Fingerprint.REFC (+    help+  ) where++import Data.Int++import Text.PrintOption++-----------------------------------------------------------++p :: Char -> String -> IO ()+p c = printOption ' ' $ " " ++ [c] ++ " --"++maxWidth :: Int+maxWidth = 80++num32BitVals :: Integer+num32BitVals = fromIntegral maxB - fromIntegral minB+  where+    maxB = maxBound :: Int32+    minB = minBound :: Int32++help :: IO ()+help = do+  p 'R' $ "Pop a vector off the stack. Push a scalar onto the stack unique to that vector. If 'R' is called multiple"+    ++ " times with equivalent vectors, each one gets a different unique scalar. Should the interpreter run out"+    ++ " of unique values, an error message will be emitted, and the program will end. The number of unique values"+    ++ " is equivalent to the number of values the funge cell size can acquire. For example, if 32 bit integers"+    ++ " are used, 'R' can be used safely " ++ show num32BitVals ++ " times."+  p 'D' $ "Pop X. If X corresponds to a vector via the 'R' instruction, push that vector onto the stack."+    ++ " Otherwise reverse the current IP (X is still popped)."+  putStrLn $ fit maxWidth $ "Note that the memory used to keep these correspondences are never freed"+    ++ " during the execution of the program. Hence if used enough, it is more likely that the program will fail"+    ++ " due to too much memory being used than not being able to create a new unique value."+
+ src/Text/Help/Fingerprint/ROMA.hs view
@@ -0,0 +1,21 @@+module Text.Help.Fingerprint.ROMA (+    help+  ) where++import Text.PrintOption++-----------------------------------------------------------++p :: Char -> String -> IO ()+p c = printOption ' ' $ " " ++ [c] ++ " --"++help :: IO ()+help = do+  p 'C' "Push 100 onto the stack."+  p 'D' "Push 500 onto the stack."+  p 'I' "Push 1 onto the stack."+  p 'L' "Push 50 onto the stack."+  p 'M' "Push 1000 onto the stack."+  p 'V' "Push 5 onto the stack."+  p 'X' "Push 10 onto the stack."+
+ src/Text/Help/Fingerprint/STRN.hs view
@@ -0,0 +1,54 @@+module Text.Help.Fingerprint.STRN (+    help+  ) where++import Text.PrintOption++-----------------------------------------------------------++p :: Char -> String -> IO ()+p c = printOption ' ' $ " " ++ [c] ++ " --"++maxWidth :: Int+maxWidth = 80++line :: IO ()+line = putStrLn $ replicate maxWidth '-'++help :: IO ()+help = do+  putStrLn $ fit maxWidth $ "All strings described by this fingerprint (STRN) are 0 terminated strings."+    ++ " By default, let variables of the form S or S# be strings. Strings are stored on the stack such that"+    ++ " the terminating 0 is popped last. Let |S| be defined to the the length of S"+    ++ " excluding the terminating 0. Note that strings are simply sequences of integer values."+  line+  p 'A' "Pop S1. Pop S2. Push the string formed by appending S2 to S1."+  p 'C' $ "Pop S1. Pop S2. Push 1 if S1 > S2. Push -1 if S1 < S2. Otherwise push 0. These comparisons are"+    ++ " done lexicographically."+  p 'D' $ "Output the string as Unicode characters to the standard output. Any numbers that cannot be converted"+    ++ " to Unicode characters are displayed as question marks ('?')."+  p 'F' $ "Pop S1. Pop S2. While S2 is not a prefix of S1 and S1 is not the empty string, drop a value from S1."+    ++ " Push the resulting string S1."+  p 'G' $ "Pop a vector V. Read a string from funge space beginning at V, heading east, until a 0 is encountered."+    ++ " The read string may wrap across the edge of space exactly as an IP would normally wrap with a delta of east."+    ++ " Push the read string."+  p 'I' $ "Read a line from the standard input. Push the resulting string onto the stack. The newline is not part of"+    ++ " the string."+  p 'L' $ "Pop N. Pop S. If N < 0, push the empty string. If N > |S|, push S. Otherwise push the string composed of"+    ++ " the first N values of S."+  p 'M' $ "Pop N. Pop P. Pop S. If N < 0 or P > |S|, push the empty string. If P < 0, let Z = S. Otherwise let Z be"+    ++ " the string S but with the first P characters removed. If N > |Z|, push Z. Otherwise push the string"+    ++ " consisting of the first N characters of Z."+  p 'N' "Pop S. Push S. Push |S|."+  p 'P' $ "Pop S. Pop a vector V. Store the string S in funge space at beginning at position V, heading east."+    ++ " Note that the terminating 0 is stored in funge space."+  p 'R' $ "Pop N. Pop S. If N < 0, push the empty string. If N > |S|, push S. Otherwise push the string"+    ++ " composed of the last N values of S."+  p 'S' $ "Pop N. Push the ASCII string representation of N. Note that if N < 0, a '-' (45) will be pushed last."+    ++ " If N >= 0, a '+' (43) is NOT pushed at all."+  p 'V' $ "Pop S. Let Z be the string S but with leading (Latin-1) whitespace stripped. Read an integer from Z,"+    ++ " optionally signed with a '+' (43) or a '-' (45). The reading is done until a value outside of '0'-'9'"+    ++ " (48-57) is encountered. Let N be the resulting integer or 0 if nothing can be read. If the cell size"+    ++ " is bounded, N will be appropriately constrained by the bounds. (For example, if the S = \"2147483648\","+    ++ "  N will be 2147483647, not -2147483648 if the cell size is 32 bits.) Push N."+
+ src/Text/Help/Fungi.hs view
@@ -0,0 +1,99 @@+module Text.Help.Fungi (+    help+  ) where++import Data.ByteSize (byteSize)+import Data.Char (chr, toLower)+import Data.Int+import Data.List (sort, intercalate, nub)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)++import System.Environment (getProgName)+import System.FilePath (dropExtension)++import Text.PrintOption++import Fingerprint++-----------------------------------------------------------++p :: Char -> String -> String -> IO ()+p = printOption++b :: Char -> String -> String -> IO ()+b = printOptionWith defaultPrintSettings { bulletDelim = Just "***" }++supportedSizes :: String+supportedSizes = intercalate ", " $ map show $ sort $ nub $ map (fromMaybe 0) [+    byteSize (0 :: Integer)+  , byteSize (0 :: Int)+  , byteSize (0 :: Int8)+  , byteSize (0 :: Int16)+  , byteSize (0 :: Int32)+  , byteSize (0 :: Int64)+  ]++fingers :: String+fingers = intercalate ", " $ sort $ map (reverse . decode) $ Map.keys (fingerprints :: Fingerprints Integer)+  where+    decode x = if x == 0+      then ""+      else chr (fromInteger m) : decode d+      where+        (d, m) = x `divMod` 256++line :: IO ()+line = putStrLn $ replicate maxWidth '-'++maxWidth :: Int+maxWidth = 80++help :: IO ()+help = do+  line+  progName <- fmap (map toLower . dropExtension) getProgName+  putStrLn $ "Usage: " ++ progName ++ " [OPTIONS] [PROGRAM FILE] [PROGRAM ARGS]"+  line+  putStrLn $ "Options:"+  p '?' "help" "Display this help message."+  p ' ' "version" "Display version."+  p ' ' "finger-doc NAME" "Display documentation for the fingerprint with name NAME."+  b 'd' "debug [MODE=1]" $ concat [+      "Run program using debugger."+    , "***MODE=1,on,true: Run debugger in step mode."+    , "***MODE=0,off,false: Run without debugger."+    , "\nDefault is off."+    ]+  p 's' "cell-size SIZE" $ concat [+      "Set the funge cell byte size to SIZE.\n"+    , "Supported sizes are " ++ supportedSizes ++ ".\n"+    , "If SIZE <= 0 then cell size is unbounded.\n"+    , "Default is " ++ show (fromMaybe 0 $ byteSize (0 :: Int)) ++ "."+    ]+  b 'n' "dim DIM" $ concat [+      "Set the funge dimensions to DIM."+    , "\nDefault depends on file extension:"+    , "***uf u98: 1"+    , "***bf b98: 2"+    , "***tf t98: 3"+    , "\nAll other extensions default to 2."+    , "\nAllowed values: 0 < DIM <= " ++ show (maxBound :: Int) ++ "."+    ]+  b 'u' "unknown MODE" $ concat [+      "What to do when encountering an unknown instruction."+    , "***MODE=reverse: Reverse on unknown instruction."+    , "***MODE=debug: Launch debugger on unknown instruction. Instruction reverses."+    , "***MODE=fail: Terminate program on unknown instruction."+    , "\nDefault is reverse."+    ]+  line+  p ' ' "FINGERPRINTS--" fingers+  line+  putStrLn $ fit maxWidth $ "There is also the +RTS option if Fungi was compiled via the GHC"+    ++ " (Glaskow Haskell Compiler). This option deals with run time options of the program and is not determined"+    ++ " by Fungi. Using this option may improve performance of Fungi. However, this option"+    ++ " (and options related to +RTS) is beyond the scope of this program. See GHC documentation"+    ++ " for more details."+  line+
+ src/Text/PrettyShow.hs view
@@ -0,0 +1,52 @@+module Text.PrettyShow (+    PrettyShow (..)+  , pprint+  ) where++import Data.Int++-----------------------------------------------------------++class PrettyShow a where+  pshow :: a -> String+  pshowList :: [a] -> String+  pshowList [] = "[]"+  pshowList (x:xs) = '[' : pshow x ++ pshowl xs+    where+      pshowl [] = "]"+      pshowl (y:ys) = ',' : pshow y ++ pshowl ys++instance (PrettyShow a) => PrettyShow [a] where+  pshow = pshowList++instance PrettyShow Bool where+  pshow = show++instance PrettyShow Char where+  pshow = show+  pshowList = flip showList ""+  +instance PrettyShow Integer where+  pshow = show++instance PrettyShow Int where+  pshow = show++instance PrettyShow Int8 where+  pshow = show++instance PrettyShow Int16 where+  pshow = show++instance PrettyShow Int32 where+  pshow = show++instance PrettyShow Int64 where+  pshow = show++instance (PrettyShow a, PrettyShow b) => PrettyShow (a, b) where+  pshow (a, b) = "(" ++ pshow a ++ "," ++ pshow b ++ ")"++pprint :: (PrettyShow a) => a -> IO ()+pprint = putStrLn . pshow+
+ src/Text/PrintOption.hs view
@@ -0,0 +1,164 @@+module Text.PrintOption (+    printOptionWith+  , printOption+  , showOptionWith+  , showOption+  , PrintSettings (..)+  , defaultPrintSettings+  , fit+  ) where++import Data.List (stripPrefix, groupBy)++-----------------------------------------------------------++data PrintSettings = PrintSettings {+    descriptionColumn :: Int+  , maxColumn :: Int+  , newLinePadding :: String+  , bulletDisplay :: String+  , bulletIndent :: String+  , bulletDelim :: Maybe String+  }++defaultPrintSettings :: PrintSettings+defaultPrintSettings = PrintSettings {+    descriptionColumn = 30+  , maxColumn = 80+  , newLinePadding = replicate 2 ' '+  , bulletDisplay = "- "+  , bulletIndent = "  "+  , bulletDelim = Nothing+  }++afterLast :: (Eq a) => a -> [a] -> [a]+afterLast x xs = afterLast' xs xs+  where+    afterLast' [] zs = zs+    afterLast' (y:ys) zs = if x == y+      then afterLast' ys ys+      else afterLast' ys zs++mapTail :: (a -> a) -> [a] -> [a]+mapTail _ [] = []+mapTail f (x:xs) = x : map f xs++appendLineIfTooLong :: PrintSettings -> String -> String+appendLineIfTooLong settings optionDisplay = if furthestCol < descCol - 1+  then optionDisplay+  else optionDisplay ++ "\n"+  where+    descCol = descriptionColumn settings+    furthestCol = foldr (max . length) 0 $ lines optionDisplay++columnize :: PrintSettings -> Int -> String -> String+columnize settings maxWidth string = columnize' string "" "" False+  where+    padding = newLinePadding settings+    bulDelim = bulletDelim settings+    bulDisp = bulletDisplay settings+    bulIndent = bulletIndent settings+    --+    columnize' :: String -> String -> String -> Bool -> String+    columnize' str currLine' currWord bulleted = case bulDelim >>= (`stripPrefix` str) of+      Just str' -> if overflowsWith currWord+        then currLine <+> currWord <++> columnize' str' bulDisp "" True+        else currLine ++ currWord <++> columnize' str' bulDisp "" True+      Nothing -> case str of+        "" -> if overflowsWith currWord+          then currLine <+> currWord+          else currLine ++ currWord+        ' ':cs -> if overflowsWith currWord+          then currLine <+> columnize' cs "" (currWord ++ " ") bulleted+          else if overflowsWith $ currWord ++ " "+            then currLine ++ currWord <+> columnize' cs "" "" bulleted+            else columnize' cs (currLine ++ currWord ++ " ") "" bulleted+        '\n':cs -> if overflowsWith currWord+          then currLine <+> columnize' ('\n':cs) currWord "" False+          else currLine ++ currWord <++> columnize' cs "" "" False+        c:cs -> columnize' cs currLine (currWord ++ [c]) bulleted+      where+        currLine = dropWhile (== ' ') currLine'+        bulLen = if bulleted+          then length bulDisp+          else 0+        overflowsWith s = length (currLine ++ s) + bulLen > maxWidth+        infixr 5 <++>+        s1 <++> s2 = s1 ++ "\n" ++ padding ++ s2+        infixr 5 <+>+        s1 <+> s2 = if bulleted+          then s1 ++ "\n" ++ padding ++ bulIndent ++ s2+          else s1 <++> s2++constrainDescriptionWidth :: PrintSettings -> String -> String+constrainDescriptionWidth settings = columnize settings (maxCol - descCol)+  where+    maxCol = maxColumn settings+    descCol = descriptionColumn settings++showOptionWith :: PrintSettings -> Char -> String -> String -> String+showOptionWith settings shortOption fullOption description =+  opDisp ++ padding ++ +    ( id+    . unlines+    . mapTail (replicate (descCol - 1) ' ' ++) +    . lines+    . constrainDescriptionWidth settings+    $ description)+  where+    descCol = descriptionColumn settings+    hasShort = shortOption /= ' '+    hasFull = fullOption /= ""+    opDisp = appendLineIfTooLong settings $ "" +      ++ "  "+      ++ [if hasShort then '-' else ' ']+      ++ [shortOption] +      ++ (if hasFull && hasShort then ", --" else "")+      ++ (if hasFull && not hasShort then "  --" else "")+      ++ fullOption+    paddingLen = descCol - 1 - length (afterLast '\n' opDisp)+    padding = replicate paddingLen ' '++showOption :: Char -> String -> String -> String+showOption = showOptionWith defaultPrintSettings++dot4 :: (e -> f) -> (a -> b -> c -> d -> e) -> (a -> b -> c -> d -> f)+dot4 f g x y z = f . g x y z++printOptionWith :: PrintSettings -> Char -> String -> String -> IO ()+printOptionWith = putStr `dot4` showOptionWith++printOption :: Char -> String -> String -> IO ()+printOption = printOptionWith defaultPrintSettings++fit :: Int -> String -> String+fit maxWidth = fit' 0 . filter (/= " ") . groupBy (\x y -> all (`notElem` [x, y]) " \n")+  where+    fit' :: Int -> [String] -> String+    fit' n strs' = case strs' of +      [] -> ""+      [str] -> let len = length str+        in case str of+          "\n" -> "\n"+          _ -> if n == 0 && len >= maxWidth+            then str+            else if n + len > maxWidth+              then '\n' : str+              else str+      (str:strs@("\n":_)) -> let len = length str+        in case str of +          "\n" -> '\n' : fit' 0 strs+          _ -> if n == 0 && len >= maxWidth+            then str ++ fit' 0 strs+            else if n + len > maxWidth+              then '\n' : str ++ " " ++ fit' (len + 1) strs+              else str ++ fit' (n + len) strs+      (str:strs) -> let len = length str+        in case str of +          "\n" -> '\n' : fit' 0 strs+          _ -> if n == 0 && len >= maxWidth+            then str ++ "\n" ++ fit' 0 strs+            else if n + len + 1 > maxWidth+              then '\n' : str ++ " " ++ fit' (len + 1) strs+              else str ++ " " ++ fit' (n + len + 1) strs+
+ src/UnknownInstruction.hs view
@@ -0,0 +1,12 @@+module UnknownInstruction (+    UnknownInstruction (..)+  ) where++-----------------------------------------------------------++data UnknownInstruction+  = ReverseUnknown+  | FailUnknown+  | DebugUnknown+  deriving (Show, Eq, Ord)+
+ src/Version.hs view
@@ -0,0 +1,13 @@+module Version (+    handprint+  , version+  ) where++-----------------------------------------------------------++handprint :: Num a => a+handprint = 378447798++version :: String+version = "1.0.4"+