Fungi (empty) → 1.0
raw patch · 46 files changed
+3964/−0 lines, 46 filesdep +ListZipperdep +basedep +bytestringsetup-changed
Dependencies added: ListZipper, base, bytestring, containers, directory, filepath, mtl, mwc-random, old-time, process, random
Files
- Data/ByteSize.hs +30/−0
- Data/Deque.hs +86/−0
- Data/History.hs +101/−0
- Data/I.hs +25/−0
- Data/IntegralLike.hs +24/−0
- Data/Labeled.hs +19/−0
- Data/LogicalBits.hs +23/−0
- Data/MaybeBounded.hs +36/−0
- Data/Stack.hs +63/−0
- Data/Vector.hs +75/−0
- Debug/Debug.hs +377/−0
- Debug/Debugger.hs +40/−0
- Env.hs +155/−0
- Fingerprint.hs +54/−0
- Fingerprint/BASE.hs +93/−0
- Fingerprint/BOOL.hs +32/−0
- Fingerprint/CPLI.hs +71/−0
- Fingerprint/FIXP.hs +118/−0
- Fingerprint/MODE.hs +107/−0
- Fingerprint/MODU.hs +28/−0
- Fingerprint/NULL.hs +16/−0
- Fingerprint/ORTH.hs +96/−0
- Fingerprint/REFC.hs +43/−0
- Fingerprint/ROMA.hs +44/−0
- Fungi.cabal +108/−0
- Fungi.hs +99/−0
- Instruction.hs +874/−0
- Interpreter.hs +68/−0
- Ip.hs +114/−0
- LICENSE +30/−0
- Main.hs +13/−0
- Math.hs +24/−0
- Mode.hs +19/−0
- ProcessArgs.hs +108/−0
- Random.hs +48/−0
- Semantics.hs +123/−0
- Setup.hs +2/−0
- Space/Cell.hs +49/−0
- Space/Space.hs +161/−0
- System/IO/Buffering.hs +17/−0
- Text/Help/Debug.hs +52/−0
- Text/Help/Fungi.hs +90/−0
- Text/PrettyShow.hs +52/−0
- Text/PrintOption.hs +132/−0
- UnknownInstruction.hs +12/−0
- Version.hs +13/−0
+ 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+
+ 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)++
+ 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]+++
+ Data/I.hs view
@@ -0,0 +1,25 @@+module Data.I (+ I+ ) where++import Data.Bits+import Data.ByteSize+import Data.Int+import Data.MaybeBounded++import Text.PrettyShow++import Random++-----------------------------------------------------------++-- The I type class is intentionally empty. Used to clump the type classes.+class (Bits i, ByteSize i, Integral 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+
+ Data/IntegralLike.hs view
@@ -0,0 +1,24 @@+module Data.IntegralLike (+ IntegralLike (..)+ ) where++import Data.Char (ord)++-----------------------------------------------------------++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 Int where+ asIntegral = fromIntegral++instance IntegralLike Integer where+ asIntegral = fromInteger+
+ 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 }+
+ 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+
+ 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+
+ 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)+
+ 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+
+ 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+
+ 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 } +
+ 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+
+ Fingerprint.hs view
@@ -0,0 +1,54 @@+module Fingerprint (+ fingerprints+ ) where++import Data.Char (ord)+import Data.IntegralLike+import Data.List (foldl')+import Data.Map (Map)+import qualified Data.Map as Map++import Instruction++import qualified Fingerprint.BASE as BASE+import qualified Fingerprint.BOOL as BOOL+import qualified Fingerprint.CPLI as CPLI+import qualified Fingerprint.FIXP as FIXP+import qualified Fingerprint.MODE as MODE+import qualified Fingerprint.MODU as MODU+import qualified Fingerprint.NULL as NULL+import qualified Fingerprint.ORTH as ORTH+import qualified Fingerprint.REFC as REFC+import qualified Fingerprint.ROMA as ROMA++-----------------------------------------------------------++type Fingerprints i = Map Integer [(i, Instruction i ())]++mapFst :: (a -> c) -> (a, b) -> (c, b)+mapFst f (x, y) = (f x, y)++mapSnd :: (b -> c) -> (a, b) -> (a, c)+mapSnd f (x, y) = (x, f y)++asId :: String -> Integer+asId = fromIntegral . foldl' (\fId x -> fId * 256 + x) 0 . map ord++fingerprints :: (I i) => Fingerprints i+fingerprints = foldr (uncurry (insert . asId) . mapSnd (map $ mapFst asIntegral)) Map.empty [+ (BASE.name, BASE.semantics)+ , (BOOL.name, BOOL.semantics)+ , (CPLI.name, CPLI.semantics)+ , (FIXP.name, FIXP.semantics)+ , (MODE.name, MODE.semantics)+ , (MODU.name, MODU.semantics)+ , (NULL.name, NULL.semantics)+ , (ORTH.name, ORTH.semantics)+ , (REFC.name, REFC.semantics)+ , (ROMA.name, ROMA.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+
+ 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+
+ 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+
+ 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+
+ Fingerprint/FIXP.hs view
@@ -0,0 +1,118 @@+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 $ fromInteger . squareRoot . fromIntegral++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+
+ Fingerprint/MODE.hs view
@@ -0,0 +1,107 @@+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.Hover+ modify $ withSemantics $ Semantics.toggleOverlay Mode.Hover hovermodeInstructions++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.Switch+ modify $ withSemantics $ Semantics.toggleOverlay Mode.Switch switchmodeInstructions+++
+ 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+
+ Fingerprint/NULL.hs view
@@ -0,0 +1,16 @@+module Fingerprint.NULL (+ name+ , semantics+ ) where++import Instruction++-----------------------------------------------------------++name :: String+name = "NULL"++semantics :: (I i) => [(Char, Instruction i ())]+semantics = zip ['A'..'Z'] $ repeat reverseInstr++
+ 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 $ replicateM_ 2 moveByDeltaInstr++sInstr :: (I i) => Instruction i ()+sInstr = do+ s <- liftM (map $ fromMaybe '?') popStringInstr+ liftIO $ putStr s+
+ 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+
+ 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+
+ Fungi.cabal view
@@ -0,0 +1,108 @@+-- Fungi.cabal auto-generated by cabal init. For additional options,+-- see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name: Fungi++-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version: 1.0++-- A short (one-line) description of the package.+Synopsis: An interpreter for Funge-98 programming languages, including Befunge.++-- A longer description of the package.+Description: Fungi is a standards compliant Funge-98 interpreter equipped with an integrated debugger.+ Supports funges of arbitrary dimensions, including Unefunge, Befunge, and Trefunge.+ Allows limited control of funge cell size.+ Several fingerprints are implemented.++License: BSD3++License-file: LICENSE++Author: Thomas Eding++Maintainer: thomasedingcode@gmail.com++-- Copyright: ++Category: Compilers/Interpreters++Build-type: Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+-- Extra-source-files: ++Cabal-version: >=1.2+++Executable: fungi++Main-is: Main.hs++GHC-options: -Wall++Build-depends:+ base >= 4.2 && < 5+ , bytestring >= 0.9+ , containers >= 0.3+ , directory >= 1.0+ , filepath >= 1.1+ , ListZipper >= 1.2+ , mtl >= 1.1+ , mwc-random >= 0.8+ , old-time >= 1.0+ , process >= 1.0+ , random >= 1.0+ +-- Modules not exported by this package.+Other-modules:+ Data.ByteSize+ , Data.Deque+ , Data.History+ , Data.I+ , Data.IntegralLike+ , Data.Labeled+ , Data.LogicalBits+ , Data.MaybeBounded+ , Data.Stack+ , Data.Vector+ , Debug.Debug+ , Debug.Debugger+ , Env+ , Fingerprint+ , Fingerprint.BASE+ , Fingerprint.BOOL+ , Fingerprint.CPLI+ , Fingerprint.FIXP+ , Fingerprint.MODE+ , Fingerprint.MODU+ , Fingerprint.NULL+ , Fingerprint.ORTH+ , Fingerprint.REFC+ , Fingerprint.ROMA+ , Fungi+ , Instruction+ , Interpreter+ , Ip+ , Math+ , Mode+ , ProcessArgs+ , Random+ , Semantics+ , Space.Cell+ , Space.Space+ , System.IO.Buffering+ , Text.Help.Debug+ , Text.Help.Fungi+ , Text.PrettyShow+ , Text.PrintOption+ , UnknownInstruction+ , Version+ +-- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+-- Build-tools: +
+ Fungi.hs view
@@ -0,0 +1,99 @@+module Fungi (+ main+ ) 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.Environment (getArgs)+import System.Exit (ExitCode (..))+import System.FilePath (takeExtension)+import System.IO hiding (hGetContents)++import Text.Help.Fungi (help)++import Env+import Fingerprint+import Instruction+import Interpreter+import ProcessArgs++-----------------------------------------------------------++main :: IO ExitCode+main = do+ mArgs <- liftM processArgs getArgs+ case mArgs of+ Nothing -> badArgs >> return (ExitFailure 1)+ Just args+ | argsHelp args -> help >> return ExitSuccess+ | otherwise -> 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."++badArgs :: IO ()+badArgs = putStrLn "Bad arguments." >> usage+
+ Instruction.hs view
@@ -0,0 +1,874 @@+module Instruction (+ I+ , Instruction+ , buildInstructions+ , baseInstructions+ , lookupInstruction+ , runCurrentInstruction++ , guardDim+ , guardZero++ , ifInstr+ , moveByDeltaInstr+ , setDeltaInstr+ , setPosInstr+ , opInstr+ , op2Instr+ , pushVectorInstr+ , popInstr+ , popNInstr_+ , popVectorInstr+ , popDimVectorInstr+ , popStringInstr+ , tryLiftIO++ , nopInstr+ , pushInstr+ , trampolineInstr+ , reverseInstr+ , loadSemanticsInstr+ , unloadSemanticsInstr+ , beginBlockInstr+ , endBlockInstr+ , turnLeftInstr+ , turnRightInstr+ , putInstr+ , getInstr+ , logicalNotInstr++ ) where++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.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 :: (Num a) => a -> Bool+numToBool 0 = False+numToBool _ = True++mapFst :: (a -> c) -> (a, b) -> (c, b)+mapFst f (x, y) = (f x, y)++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) => [(Char, v)] -> Map i v+buildInstructions = Map.fromList . map (mapFst $ fromIntegral . ord)++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 [0]+ 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 :: (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 mod++-----------------------------------------------------------+-- Strings+-----------------------------------------------------------++stringmodeInstructions :: (I i) => (i -> Maybe (Instruction i ()), Map i (Maybe (Instruction i ())))+stringmodeInstructions = (,) (Just . pushInstr) $ buildInstructions [+ ('"', Nothing)+ , (' ', 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.String+ modify $ withSemantics $ Semantics.toggleOverlay Mode.String stringmodeInstructions++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 $ show 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 }+
+ 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+
+ Ip.hs view
@@ -0,0 +1,114 @@+module Ip (+ Ip+ , mkIp++ , getId+ , getPos+ , getDelta+ , getSs+ , isAlive+ , getStorageOffset+ , getSemantics++ , testMode+ , addMode+ , removeMode+ , toggleMode++ , killIp+ , reverseIp+ , setPos+ , setDelta+ , setSs+ , setStorageOffset++ ) where++import Control.Monad.State.Strict++import Data.Deque+import Data.I+import Data.Map (Map)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Stack+import Data.Vector++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 :: Set Mode+ }++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 (Set.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 = Set.empty+ }++testMode :: Mode -> Ip env i -> Bool+testMode mode = Set.member mode . modes++addMode :: Mode -> Ip env i -> Ip env i+addMode mode ip = ip { modes = Set.insert mode $ modes ip }++removeMode :: Mode -> Ip env i -> Ip env i+removeMode mode ip = ip { modes = Set.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 }+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2010, Thomas Eding++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Thomas Eding nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,13 @@+module Main (+ )+ where++import System.Exit++import qualified Fungi++-----------------------------------------------------------++main :: IO ExitCode+main = Fungi.main+
+ 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+
+ Mode.hs view
@@ -0,0 +1,19 @@+module Mode (+ Mode (..)+ ) where++import Text.PrettyShow++-----------------------------------------------------------++data Mode+ = Hover+ | Invert+ | String+ | Switch+ | Queue+ deriving (Show, Eq, Ord)++instance PrettyShow Mode where+ pshow = show+
+ ProcessArgs.hs view
@@ -0,0 +1,108 @@+module ProcessArgs (+ processArgs+ , ProcessedArgs ()+ , argsHelp+ , argsDebugMode+ , argsCellByteSize+ , argsDim+ , argsUnknownMode+ , argsFile+ , argsFungeArgs+ ) where++import Control.Monad++import Data.ByteSize (byteSize)+import Data.Char (toLower)++import Debug.Debugger (DebugMode (..))++import UnknownInstruction++-----------------------------------------------------------++data ProcessedArgs = ProcessedArgs {+ argsHelp :: Bool+ , 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+ , 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+ "--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 }++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+ }+
+ 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+
+ Semantics.hs view
@@ -0,0 +1,123 @@+module Semantics (+ Semantics+ , mkSemantics+ , lookup+ , 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 $ map unlabel $ overlayInstrs sem of+ Just instr -> Just instr+ Nothing -> case lookupFinger i $ fingerInstrs sem of+ Just instr -> Just instr+ Nothing -> lookupBase i $ baseInstrs sem++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+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ 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 (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+
+ Space/Space.hs view
@@ -0,0 +1,161 @@+module Space.Space (+ Space+ , mkSpace+ , cellAt+ , putCell+ , travelBy+ , minMaxCoords+ , putSpaceAt+ ) 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, 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')+
+ 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+
+ 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."+
+ Text/Help/Fungi.hs view
@@ -0,0 +1,90 @@+module Text.Help.Fungi (+ help+ ) where++import Data.ByteSize (byteSize)+import Data.Char (toLower)+import Data.Int+import Data.List (sort, intercalate, nub)+import Data.Maybe (fromMaybe)++import System.Environment (getProgName)+import System.FilePath (dropExtension)++import Text.PrintOption++-----------------------------------------------------------++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)+ ]++fingerprints :: String+fingerprints = intercalate ", " $ sort [+ "BASE"+ , "BOOL"+ , "CPLI"+ , "FIXP"+ , "MODE"+ , "MODU"+ , "NULL"+ , "ORTH"+ , "REFC"+ , "ROMA"+ ]++line :: IO ()+line = putStrLn $ replicate 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."+ 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--" fingerprints+ line+
+ 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+
+ Text/PrintOption.hs view
@@ -0,0 +1,132 @@+module Text.PrintOption (+ printOptionWith+ , printOption+ , showOptionWith+ , showOption+ , PrintSettings (..)+ , defaultPrintSettings+ ) where++import Data.List (stripPrefix)++-----------------------------------------------------------++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+
+ UnknownInstruction.hs view
@@ -0,0 +1,12 @@+module UnknownInstruction (+ UnknownInstruction (..)+ ) where++-----------------------------------------------------------++data UnknownInstruction+ = ReverseUnknown+ | FailUnknown+ | DebugUnknown+ deriving (Show, Eq, Ord)+
+ Version.hs view
@@ -0,0 +1,13 @@+module Version (+ handprint+ , version+ ) where++-----------------------------------------------------------++handprint :: Num a => a+handprint = 378447798++version :: Double+version = 1.0+