diff --git a/Data/I.hs b/Data/I.hs --- a/Data/I.hs +++ b/Data/I.hs @@ -5,6 +5,7 @@ import Data.Bits import Data.ByteSize import Data.Int +import Data.IntegralLike import Data.MaybeBounded import Text.PrettyShow @@ -14,7 +15,7 @@ ----------------------------------------------------------- -- 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 +class (Bits i, ByteSize i, Integral i, IntegralLike i, MaybeBounded i, PrettyShow i, Random i, Read i) => I i where instance I Integer where instance I Int where diff --git a/Data/IntegralLike.hs b/Data/IntegralLike.hs --- a/Data/IntegralLike.hs +++ b/Data/IntegralLike.hs @@ -3,6 +3,7 @@ ) where import Data.Char (ord) +import Data.Int ----------------------------------------------------------- @@ -16,9 +17,21 @@ instance IntegralLike Char where asIntegral = fromIntegral . ord +instance IntegralLike Integer where + asIntegral = fromInteger + instance IntegralLike Int where asIntegral = fromIntegral -instance IntegralLike Integer where - asIntegral = fromInteger +instance IntegralLike Int8 where + asIntegral = fromIntegral + +instance IntegralLike Int16 where + asIntegral = fromIntegral + +instance IntegralLike Int32 where + asIntegral = fromIntegral + +instance IntegralLike Int64 where + asIntegral = fromIntegral diff --git a/Data/Tuple/Map.hs b/Data/Tuple/Map.hs new file mode 100644 --- /dev/null +++ b/Data/Tuple/Map.hs @@ -0,0 +1,16 @@ +module Data.Tuple.Map ( + map1 + , map2 + ) where + +import Data.Tuple.Select +import Data.Tuple.Update + +----------------------------------------------------------- + +map1 :: (Sel1 a1 a, Upd1 b a1 c) => (a -> b) -> a1 -> c +map1 f t = upd1 (f $ sel1 t) t + +map2 :: (Sel2 a1 a, Upd2 b a1 c) => (a -> b) -> a1 -> c +map2 f t = upd2 (f $ sel2 t) t + diff --git a/Fingerprint.hs b/Fingerprint.hs --- a/Fingerprint.hs +++ b/Fingerprint.hs @@ -8,16 +8,20 @@ import Data.List (foldl') import Data.Map (Map) import qualified Data.Map as Map +import Data.Tuple.Map import Instruction import qualified Fingerprint.BASE as BASE +import qualified Fingerprint.BF93 as BF93 import qualified Fingerprint.BOOL as BOOL +import qualified Fingerprint.BZRO as BZRO import qualified Fingerprint.CPLI as CPLI import qualified Fingerprint.FIXP as FIXP import qualified Fingerprint.HRTI as HRTI import qualified Fingerprint.MODE as MODE import qualified Fingerprint.MODU as MODU +import qualified Fingerprint.NOP as NOP import qualified Fingerprint.NULL as NULL import qualified Fingerprint.ORTH as ORTH import qualified Fingerprint.REFC as REFC @@ -27,24 +31,21 @@ 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 [ +fingerprints = foldr (uncurry (insert . asId) . map2 (map $ map1 asIntegral)) Map.empty [ (BASE.name, BASE.semantics) + , (BF93.name, BF93.semantics) , (BOOL.name, BOOL.semantics) + , (BZRO.name, BZRO.semantics) , (CPLI.name, CPLI.semantics) , (FIXP.name, FIXP.semantics) , (HRTI.name, HRTI.semantics) , (MODE.name, MODE.semantics) , (MODU.name, MODU.semantics) + , (NOP.name, NOP.semantics ) , (NULL.name, NULL.semantics) , (ORTH.name, ORTH.semantics) , (REFC.name, REFC.semantics) diff --git a/Fingerprint/BF93.hs b/Fingerprint/BF93.hs new file mode 100644 --- /dev/null +++ b/Fingerprint/BF93.hs @@ -0,0 +1,82 @@ +module Fingerprint.BF93 ( + name + , semantics + ) where + +import Prelude hiding (lookup) + +import Control.Monad.State.Strict + +import Data.Map (Map) + +import System.Exit (exitWith, ExitCode (ExitSuccess)) + +import Env +import Instruction +import Ip +import Mode +import Semantics + +----------------------------------------------------------- + +name :: String +name = "BF93" + +semantics :: (I i) => [(Char, Instruction i ())] +semantics = [ + ('B', bInstr) + ] + +string93modeInstructions :: (I i) => (i -> Maybe (Instruction i ()), Map i (Maybe (Instruction i ()))) +string93modeInstructions = (,) (Just . pushInstr) $ buildInstructions [ + ('"', Just string93modeInstr) + ] + +string93modeInstr :: (I i) => Instruction i () +string93modeInstr = do + modify $ withIp $ toggleMode mode + modify $ withSemantics $ Semantics.toggleOverlay mode string93modeInstructions + where + mode = Mode.String93 + +exitInstr :: (I i) => Instruction i () +exitInstr = liftIO $ exitWith ExitSuccess + +befunge93modeInstructions :: (I i) => (i -> Maybe (Instruction i ()), Map i (Maybe (Instruction i ()))) +befunge93modeInstructions = (,) (const $ Just reverseInstr) $ buildInstructions [ + ('"', Just string93modeInstr) + , ('@', Just exitInstr) + , (' ', Just spaceInstr) + , ('+', Just addInstr) + , ('-', Just subtractInstr) + , ('*', Just multiplyInstr) + , ('/', Just divideInstr) + , ('%', Just remainderInstr) + , ('`', Just greaterThanInstr) + , ('>', Just goEastInstr) + , ('<', Just goWestInstr) + , ('^', Just goNorthInstr) + , ('v', Just goSouthInstr) + , ('?', Just goAwayInstr) + , ('_', Just eastWestIfInstr) + , ('|', Just northSouthIfInstr) + , (':', Just duplicateInstr) + , ('\\',Just swapInstr) + , ('$', Just popInstr_) + , ('.', Just outputDecimalInstr) + , (',', Just outputCharacterInstr) + , ('#', Just trampolineInstr) + , ('g', Just getInstr) + , ('p', Just putInstr) + , ('&', Just inputDecimalInstr) + , ('~', Just inputCharacterInstr) + , ('!', Just logicalNotInstr) + ] + +bInstr :: (I i) => Instruction i () +bInstr = do + modify $ withIp $ toggleMode mode + modify $ withSemantics $ Semantics.toggleOverlay mode befunge93modeInstructions + where + mode = Mode.Befunge93 + diff --git a/Fingerprint/BZRO.hs b/Fingerprint/BZRO.hs new file mode 100644 --- /dev/null +++ b/Fingerprint/BZRO.hs @@ -0,0 +1,89 @@ +module Fingerprint.BZRO ( + name + , semantics + ) where + +import Prelude hiding (lookup) + +import Control.Monad.State.Strict + +import Data.Char (chr, ord) +import Data.Map (Map) +import Data.Tuple.Map + +import Space.Cell + +import Env +import Instruction +import Ip +import Mode +import Semantics + +----------------------------------------------------------- + +name :: String +name = "BZRO" + +semantics :: (I i) => [(Char, Instruction i ())] +semantics = [ + ('B', bInstr) + ] + +runInstructionInstr :: (I i) => Char -> Instruction i () +runInstructionInstr c = do + sem <- gets $ removeOverlay Mode.Bizarro . getSemantics . currentIp + case lookup i sem of + Just instr -> instr + Nothing -> unknownInstr i + where + i = ordCell $ charToCell c + +bizarromodeInstructions :: (I i) => (i -> Maybe (Instruction i ()), Map i (Maybe (Instruction i ()))) +bizarromodeInstructions = (,) f $ buildInstructions $ map (map2 $ Just . runInstructionInstr) [ + ('>', '<') + , ('<', '>') + , ('^', 'v') + , ('v', '^') + , ('h', 'l') + , ('l', 'h') + , ('[', ']') + , (']', '[') + , ('_', '|') + , ('|', '_') + , ('(', ')') + , (')', '(') + , ('{', '}') + , ('}', '{') + , ('+', '-') + , ('-', '+') + , ('*', '/') + , ('/', '*') + , ('i', 'o') + , ('o', 'i') + , ('&', '.') + , ('.', '&') + , ('~', ',') + , (',', '~') + , ('g', 'p') + , ('p', 'g') + , ('@', 'q') + , ('q', '@') + , ('\'','"') + , ('"','\'') + ] + where + f x = case cellToChar $ chrCell x of + Just c + | c `elem` ['0'..'9'] -> Just $ map runInstructionInstr "fedcba9876" !! (ord c - ord '0') + | c `elem` ['a'..'f'] -> Just $ map runInstructionInstr "543210" !! (ord c - ord 'a') + | c `elem` ['A'..'Z'] -> Just $ runInstructionInstr $ chr $ ord 'Z' + ord 'A' - ord c + | otherwise -> Nothing + Nothing -> Nothing + +bInstr :: (I i) => Instruction i () +bInstr = do + modify $ withIp $ toggleMode mode + modify $ withSemantics $ Semantics.toggleOverlay mode bizarromodeInstructions + where + mode = Mode.Bizarro + diff --git a/Fingerprint/FIXP.hs b/Fingerprint/FIXP.hs --- a/Fingerprint/FIXP.hs +++ b/Fingerprint/FIXP.hs @@ -94,7 +94,9 @@ pow10 = 10 ^ (length (show pi) - 1) qInstr :: (I i) => Instruction i () -qInstr = opInstr $ fromInteger . squareRoot . fromIntegral +qInstr = opInstr $ \x -> if x >= 0 + then fromInteger $ squareRoot $ fromIntegral x + else x rInstr :: (I i) => Instruction i () rInstr = op2Instr $ \x y -> if y >= 0 diff --git a/Fingerprint/MODE.hs b/Fingerprint/MODE.hs --- a/Fingerprint/MODE.hs +++ b/Fingerprint/MODE.hs @@ -89,8 +89,10 @@ hInstr :: (I i) => Instruction i () hInstr = do - modify $ withIp $ toggleMode Mode.Hover - modify $ withSemantics $ Semantics.toggleOverlay Mode.Hover hovermodeInstructions + modify $ withIp $ toggleMode mode + modify $ withSemantics $ Semantics.toggleOverlay mode hovermodeInstructions + where + mode = Mode.Hover iInstr :: (I i) => Instruction i () iInstr = modify $ withIp $ toggleMode Mode.Invert @@ -100,8 +102,8 @@ sInstr :: (I i) => Instruction i () sInstr = do - modify $ withIp $ toggleMode Mode.Switch - modify $ withSemantics $ Semantics.toggleOverlay Mode.Switch switchmodeInstructions - - + modify $ withIp $ toggleMode mode + modify $ withSemantics $ Semantics.toggleOverlay mode switchmodeInstructions + where + mode = Mode.Switch diff --git a/Fingerprint/NOP.hs b/Fingerprint/NOP.hs new file mode 100644 --- /dev/null +++ b/Fingerprint/NOP.hs @@ -0,0 +1,15 @@ +module Fingerprint.NOP ( + name + , semantics + ) where + +import Instruction + +----------------------------------------------------------- + +name :: String +name = "NOP" + +semantics :: (I i) => [(Char, Instruction i ())] +semantics = zip ['A'..'Z'] $ repeat nopInstr + diff --git a/Fingerprint/NULL.hs b/Fingerprint/NULL.hs --- a/Fingerprint/NULL.hs +++ b/Fingerprint/NULL.hs @@ -13,4 +13,3 @@ semantics :: (I i) => [(Char, Instruction i ())] semantics = zip ['A'..'Z'] $ repeat reverseInstr - diff --git a/Fingerprint/ORTH.hs b/Fingerprint/ORTH.hs --- a/Fingerprint/ORTH.hs +++ b/Fingerprint/ORTH.hs @@ -87,7 +87,7 @@ modify $ withSpace $ \s -> putCell s (chrCell x) $ takeV dim $ loc `append` 0 zInstr :: (I i) => Instruction i () -zInstr = ifInstr nopInstr $ replicateM_ 2 moveByDeltaInstr +zInstr = ifInstr nopInstr trampolineInstr sInstr :: (I i) => Instruction i () sInstr = do diff --git a/Fungi.cabal b/Fungi.cabal --- a/Fungi.cabal +++ b/Fungi.cabal @@ -7,7 +7,7 @@ -- 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.2 +Version: 1.0.3 -- A short (one-line) description of the package. Synopsis: An interpreter for Funge-98 programming languages, including Befunge. @@ -36,8 +36,22 @@ -- a README. -- Extra-source-files: -Cabal-version: >=1.2 +Cabal-version: >= 1.6 +Extra-source-files: + README + Tester.hs + runTests.bash + tests/*.bf + tests/bad/*.bf + tests/bad/fingers/bzro/*.bf + tests/good/*.bf + tests/good/*.dat + tests/good/fingers/bzro/*.bf + tests/good/fingers/mode/*.bf + tests/mycology/*.bf + tests/mycology/*.b98 + tests/mycology/*.txt Executable: fungi @@ -57,6 +71,8 @@ , old-time >= 1.0 , process >= 1.0 , random >= 1.0 + , tuple >= 0.2 + , haskell98 >= 1.0 -- Modules not exported by this package. Other-modules: @@ -69,18 +85,22 @@ Data.LogicalBits Data.MaybeBounded Data.Stack + Data.Tuple.Map Data.Vector Debug.Debug Debug.Debugger Env Fingerprint Fingerprint.BASE + Fingerprint.BF93 Fingerprint.BOOL + Fingerprint.BZRO Fingerprint.CPLI Fingerprint.FIXP Fingerprint.HRTI Fingerprint.MODE Fingerprint.MODU + Fingerprint.NOP Fingerprint.NULL Fingerprint.ORTH Fingerprint.REFC @@ -98,12 +118,35 @@ Space.Space System.IO.Buffering Text.Help.Debug + Text.Help.Fingerprint Text.Help.Fungi + Text.Help.Fingerprint.BASE + Text.Help.Fingerprint.BF93 + Text.Help.Fingerprint.BOOL + Text.Help.Fingerprint.BZRO + Text.Help.Fingerprint.CPLI + Text.Help.Fingerprint.FIXP + Text.Help.Fingerprint.HRTI + Text.Help.Fingerprint.MODE + Text.Help.Fingerprint.MODU + Text.Help.Fingerprint.NOP + Text.Help.Fingerprint.NULL + Text.Help.Fingerprint.ORTH + Text.Help.Fingerprint.REFC + Text.Help.Fingerprint.ROMA Text.PrettyShow Text.PrintOption UnknownInstruction Version - + + + + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. -- Build-tools: + + + + diff --git a/Fungi.hs b/Fungi.hs --- a/Fungi.hs +++ b/Fungi.hs @@ -1,5 +1,6 @@ module Fungi ( main + , mycology ) where import Control.Exception (handle) @@ -18,31 +19,46 @@ import Space.Space -import System.Environment (getArgs) +import System (system) +import System.Environment (getArgs, withArgs) import System.Exit (ExitCode (..)) import System.FilePath (takeExtension) import System.IO hiding (hGetContents) -import Text.Help.Fungi (help) +import qualified Text.Help.Fingerprint +import qualified Text.Help.Fungi import Env import Fingerprint import Instruction import Interpreter import ProcessArgs +import qualified Version ----------------------------------------------------------- +mycology :: IO ExitCode +mycology = do + removeTemps + ret <- withArgs ["--unknown", "debug", "tests/mycology/mycology.b98"] main + removeTemps + return ret + where + removeTemps = system "rm tests/mycology/mycotmp*.tmp" >> return () + main :: IO ExitCode main = do mArgs <- liftM processArgs getArgs case mArgs of Nothing -> badArgs >> return (ExitFailure 1) Just args - | argsHelp args -> help >> return ExitSuccess - | otherwise -> case argsFile args of - Nothing -> usage >> return ExitSuccess - Just file -> readSourceFile file >>= startFungi args file + | argsHelp args -> Text.Help.Fungi.help >> return ExitSuccess + | argsVersion args -> version >> return ExitSuccess + | otherwise -> case argsFingerDoc args of + Just fingerName -> Text.Help.Fingerprint.help fingerName >> return ExitSuccess + Nothing -> case argsFile args of + Nothing -> usage >> return ExitSuccess + Just file -> readSourceFile file >>= startFungi args file readSourceFile :: FilePath -> IO ByteString readSourceFile file = withFile file ReadMode $ \hdl -> BS.hGetContents hdl @@ -93,6 +109,10 @@ usage :: IO () usage = putStrLn "See --help for usage." + +version :: IO () +version = do + putStrLn $ "Fungi version " ++ Version.version badArgs :: IO () badArgs = putStrLn "Bad arguments." >> usage diff --git a/Instruction.hs b/Instruction.hs --- a/Instruction.hs +++ b/Instruction.hs @@ -36,6 +36,36 @@ , putInstr , getInstr , logicalNotInstr + , goWestInstr + , goEastInstr + , goNorthInstr + , goSouthInstr + , goLowInstr + , goHighInstr + , northSouthIfInstr + , eastWestIfInstr + , stopInstr + , quitInstr + , subtractInstr + , addInstr + , multiplyInstr + , divideInstr + , outputFileInstr + , inputFileInstr + , outputCharacterInstr + , inputCharacterInstr + , outputDecimalInstr + , inputDecimalInstr + , stringmodeInstr + , fetchCharacterInstr + , unknownInstr + , spaceInstr + , remainderInstr + , greaterThanInstr + , goAwayInstr + , duplicateInstr + , swapInstr + , popInstr_ ) where @@ -55,6 +85,7 @@ import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Stack as Stack +import Data.Tuple.Map import Data.Vector import Debug.Debugger @@ -91,9 +122,6 @@ 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 @@ -114,8 +142,8 @@ ----------------------------------------------------------- -buildInstructions :: (Integral i) => [(Char, v)] -> Map i v -buildInstructions = Map.fromList . map (mapFst $ fromIntegral . ord) +buildInstructions :: (Integral i, IntegralLike c) => [(c, v)] -> Map i v +buildInstructions = Map.fromList . map (map1 asIntegral) baseInstructions :: (I i) => Map i (Instruction i ()) baseInstructions = buildInstructions $ [ @@ -259,7 +287,7 @@ popStringInstr' = do x <- popInstr if x == 0 - then return [0] + then return [] else liftM (x :) popStringInstr' guardDim :: (I i) => Int -> Instruction i () -> Instruction i () @@ -471,7 +499,7 @@ divideInstr = op2Instr $ guardZero div remainderInstr :: (I i) => Instruction i () -remainderInstr = op2Instr $ guardZero mod +remainderInstr = op2Instr $ guardZero rem ----------------------------------------------------------- -- Strings @@ -479,7 +507,7 @@ stringmodeInstructions :: (I i) => (i -> Maybe (Instruction i ()), Map i (Maybe (Instruction i ()))) stringmodeInstructions = (,) (Just . pushInstr) $ buildInstructions [ - ('"', Nothing) + ('"', Just stringmodeInstr) , (' ', Just sgmlSpaceInstr) ] where @@ -491,8 +519,10 @@ stringmodeInstr :: (I i) => Instruction i () stringmodeInstr = do - modify $ withIp $ toggleMode Mode.String - modify $ withSemantics $ Semantics.toggleOverlay Mode.String stringmodeInstructions + modify $ withIp $ toggleMode mode + modify $ withSemantics $ Semantics.toggleOverlay mode stringmodeInstructions + where + mode = Mode.String fetchCharacterInstr :: (I i) => Instruction i () fetchCharacterInstr = do diff --git a/Mode.hs b/Mode.hs --- a/Mode.hs +++ b/Mode.hs @@ -7,9 +7,12 @@ ----------------------------------------------------------- data Mode - = Hover + = Befunge93 + | Bizarro + | Hover | Invert | String + | String93 | Switch | Queue deriving (Show, Eq, Ord) diff --git a/ProcessArgs.hs b/ProcessArgs.hs --- a/ProcessArgs.hs +++ b/ProcessArgs.hs @@ -1,13 +1,6 @@ module ProcessArgs ( processArgs - , ProcessedArgs () - , argsHelp - , argsDebugMode - , argsCellByteSize - , argsDim - , argsUnknownMode - , argsFile - , argsFungeArgs + , ProcessedArgs (..) ) where import Control.Monad @@ -23,6 +16,8 @@ data ProcessedArgs = ProcessedArgs { argsHelp :: Bool + , argsVersion :: Bool + , argsFingerDoc :: Maybe String , argsDebugMode :: DebugMode , argsCellByteSize :: Maybe Int , argsDim :: Maybe Int @@ -35,6 +30,8 @@ defaultProcessedArgs :: ProcessedArgs defaultProcessedArgs = ProcessedArgs { argsHelp = False + , argsVersion = False + , argsFingerDoc = Nothing , argsDebugMode = DebugOff , argsCellByteSize = byteSize (0 :: Int) , argsDim = Nothing @@ -48,6 +45,8 @@ processArgs (arg:args) = case arg of "--help" -> processHelp args "-?" -> processHelp args + "--version" -> processVersion args + "--finger-doc" -> processFingerDoc args "--debug" -> processDebug args "-d" -> processDebug args "--cell-size" -> processCellSize args @@ -60,6 +59,13 @@ processHelp :: [String] -> Maybe ProcessedArgs processHelp args = processArgs args >>= \p -> return p { argsHelp = True } + +processVersion :: [String] -> Maybe ProcessedArgs +processVersion args = processArgs args >>= \p -> return p { argsVersion = True } + +processFingerDoc :: [String] -> Maybe ProcessedArgs +processFingerDoc [] = Nothing +processFingerDoc (arg:args) = processArgs args >>= \p -> return p { argsFingerDoc = Just arg } processUknown :: [String] -> Maybe ProcessedArgs processUknown [] = Nothing diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,3 @@ +For information on how to use Fungi, run it with the --help command line argument: + +fungi --help diff --git a/Semantics.hs b/Semantics.hs --- a/Semantics.hs +++ b/Semantics.hs @@ -2,6 +2,9 @@ Semantics , mkSemantics , lookup + , lookupBase + , lookupFinger + , lookupOverlay , pushFingerprint , popFingerprint , toggleOverlay @@ -43,30 +46,39 @@ } lookup :: (I i) => i -> Semantics env i -> Maybe (Instruction env i ()) -lookup i sem = case lookupOverlay i $ map unlabel $ overlayInstrs sem of +lookup i sem = case lookupOverlay i sem of Just instr -> Just instr - Nothing -> case lookupFinger i $ fingerInstrs sem of + Nothing -> case lookupFinger i sem of Just instr -> Just instr - Nothing -> lookupBase i $ baseInstrs sem + Nothing -> lookupBase i 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 +lookupOverlay :: (I i) => i -> Semantics env i -> Maybe (Instruction env i ()) +lookupOverlay i = lookupOverlay' i . map unlabel . overlayInstrs + +lookupFinger :: (I i) => i -> Semantics env i -> Maybe (Instruction env i ()) +lookupFinger i = lookupFinger' i . fingerInstrs + +lookupBase :: (I i) => i -> Semantics env i -> Maybe (Instruction env i ()) +lookupBase i = lookupBase' i . baseInstrs + +lookupOverlay' :: (I i) => i -> [InfMap i (Instruction env i ())] -> Maybe (Instruction env i ()) +lookupOverlay' _ [] = Nothing +lookupOverlay' i ((f, m) : ms) = case Map.lookup i m of Just mInstr -> case mInstr of Just instr -> Just instr - Nothing -> lookupOverlay i ms + Nothing -> lookupOverlay' i ms Nothing -> case f i of Just instr -> Just instr - Nothing -> lookupOverlay i ms + 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 +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 +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' } diff --git a/Tester.hs b/Tester.hs new file mode 100644 --- /dev/null +++ b/Tester.hs @@ -0,0 +1,79 @@ +module Tester ( + main + ) where + +import Control.Exception (handle) +import Control.Monad + +import Data.List (sort, isSuffixOf) + +import System.Directory (getDirectoryContents, doesFileExist, doesDirectoryExist) +import System.Environment (withArgs) +import System.Exit (ExitCode (..), exitSuccess, exitFailure) + +import qualified Fungi + +----------------------------------------------------------- + +main :: IO ExitCode +main = do + putStrLn "Running Tests..." + (goodPasses, goodFailures) <- runTests goodTestDir + (badFailures, badPasses) <- runTests badTestDir + putStrLn "-----------------------------------------------------------" + putStrLn $ "Good Passes: " ++ show goodPasses + putStrLn $ "Good Failures: " ++ show goodFailures + putStrLn "-----------------------------------------------------------" + putStrLn $ "Bad Passes: " ++ show badPasses + putStrLn $ "Bad Failures: " ++ show badFailures + putStrLn "-----------------------------------------------------------" + putStrLn $ "Total Tests Passed: " ++ show (goodPasses + badPasses) + putStrLn $ "Total Tests Failed: " ++ show (goodFailures + badFailures) + if (goodFailures + badFailures) > 0 + then return $ ExitFailure 1 + else return ExitSuccess + where + goodTestDir = "tests/good/" + badTestDir = "tests/bad/" + +getDirectoryFilesRecursive :: FilePath -> IO [FilePath] +getDirectoryFilesRecursive path = do + contents <- liftM (filter (`notElem` [".", ".."])) $ getDirectoryContents path + dirs <- filterM doesDirectoryExist $ map ((path ++) . (++ "/")) contents + files <- filterM doesFileExist $ map (path ++) contents + files' <- mapM getDirectoryFilesRecursive dirs + return $ files ++ concat files' + +runTests :: FilePath -> IO (Int, Int) +runTests testDir = do + files <- return + . sort + . filter (\file -> any (`isSuffixOf` file) [".uf", ".u98", ".bf", ".b98", ".tf", ".t98"]) + =<< getDirectoryFilesRecursive testDir + exitCodes <- mapM test files + let numSuccesses = countSuccesses exitCodes + numFailures = countFailures exitCodes + return (numSuccesses, numFailures) + +countSuccesses :: [ExitCode] -> Int +countSuccesses = length . filter (== ExitSuccess) + +countFailures :: [ExitCode] -> Int +countFailures = length . filter (/= ExitSuccess) + +printOnFail :: FilePath -> ExitCode -> IO ExitCode +printOnFail file exitCode@(ExitFailure n) = do + putStrLn $ "Fail: " ++ file ++ ", with exit code " ++ show n + return exitCode +printOnFail _ exitCode = return exitCode + +test :: FilePath -> IO ExitCode +test file = do + putStrLn $ ">>>> Testing: " ++ file + exitCode <- handle return $ withArgs args Fungi.main + putStr "\n>>>> " + print exitCode + return exitCode + where + args = ["--debug", "0", file] + diff --git a/Text/Help/Fingerprint.hs b/Text/Help/Fingerprint.hs new file mode 100644 --- /dev/null +++ b/Text/Help/Fingerprint.hs @@ -0,0 +1,68 @@ +module Text.Help.Fingerprint ( + help + ) where + +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) + +import qualified Fingerprint.BASE as BASE +import qualified Fingerprint.BF93 as BF93 +import qualified Fingerprint.BOOL as BOOL +import qualified Fingerprint.BZRO as BZRO +import qualified Fingerprint.CPLI as CPLI +import qualified Fingerprint.FIXP as FIXP +import qualified Fingerprint.HRTI as HRTI +import qualified Fingerprint.MODE as MODE +import qualified Fingerprint.MODU as MODU +import qualified Fingerprint.NOP as NOP +import qualified Fingerprint.NULL as NULL +import qualified Fingerprint.ORTH as ORTH +import qualified Fingerprint.REFC as REFC +import qualified Fingerprint.ROMA as ROMA + +import qualified Text.Help.Fingerprint.BASE as H_BASE +import qualified Text.Help.Fingerprint.BF93 as H_BF93 +import qualified Text.Help.Fingerprint.BOOL as H_BOOL +import qualified Text.Help.Fingerprint.BZRO as H_BZRO +import qualified Text.Help.Fingerprint.CPLI as H_CPLI +import qualified Text.Help.Fingerprint.FIXP as H_FIXP +import qualified Text.Help.Fingerprint.HRTI as H_HRTI +import qualified Text.Help.Fingerprint.MODE as H_MODE +import qualified Text.Help.Fingerprint.MODU as H_MODU +import qualified Text.Help.Fingerprint.NOP as H_NOP +import qualified Text.Help.Fingerprint.NULL as H_NULL +import qualified Text.Help.Fingerprint.ORTH as H_ORTH +import qualified Text.Help.Fingerprint.REFC as H_REFC +import qualified Text.Help.Fingerprint.ROMA as H_ROMA + +----------------------------------------------------------- + +line :: IO () +line = putStrLn $ replicate 80 '-' + +noHelp :: String -> IO () +noHelp finger = putStrLn $ "Unable to find fingerprint documentation for " ++ finger + +help :: String -> IO () +help finger = do + line + doc + line + where + doc = fromMaybe (noHelp finger) $ Map.lookup finger $ Map.fromList [ + (BASE.name, H_BASE.help) + , (BF93.name, H_BF93.help) + , (BOOL.name, H_BOOL.help) + , (BZRO.name, H_BZRO.help) + , (CPLI.name, H_CPLI.help) + , (FIXP.name, H_FIXP.help) + , (HRTI.name, H_HRTI.help) + , (MODE.name, H_MODE.help) + , (MODU.name, H_MODU.help) + , (NOP.name , H_NOP.help ) + , (NULL.name, H_NULL.help) + , (ORTH.name, H_ORTH.help) + , (REFC.name, H_REFC.help) + , (ROMA.name, H_ROMA.help) + ] + diff --git a/Text/Help/Fingerprint/BASE.hs b/Text/Help/Fingerprint/BASE.hs new file mode 100644 --- /dev/null +++ b/Text/Help/Fingerprint/BASE.hs @@ -0,0 +1,19 @@ +module Text.Help.Fingerprint.BASE ( + help + ) where + +import Text.PrintOption + +----------------------------------------------------------- + +p :: Char -> String -> IO () +p c = printOption ' ' $ " " ++ [c] ++ " --" + +help :: IO () +help = do + p 'B' "Pop X. Output X in base 2 followed by a space." + p 'H' "Pop X. Output X in base 16 followed by a space." + p 'I' "Pop N. Read input in base N." + p 'N' "Pop X. Pop N. Output X in base N followed by a space." + p 'O' "Pop X. Output X in base 8 followed by a space." + diff --git a/Text/Help/Fingerprint/BF93.hs b/Text/Help/Fingerprint/BF93.hs new file mode 100644 --- /dev/null +++ b/Text/Help/Fingerprint/BF93.hs @@ -0,0 +1,33 @@ +module Text.Help.Fingerprint.BF93 ( + help + ) where + +import Data.List (intercalate) + +import Text.PrintOption + +----------------------------------------------------------- + +p :: Char -> String -> IO () +p c = printOption ' ' $ " " ++ [c] ++ " --" + +maxWidth :: Int +maxWidth = 80 + +line :: IO () +line = putStrLn $ replicate maxWidth '-' + +help :: IO () +help = do + p 'B' "Toggle Befunge93 mode." + line + putStrLn "\n ** BEFUNGE93 MODE **\n" + putStrLn "In Befunge93 mode, the following instructins take on new meaning: " + p '"' $ "Toggle String93 mode. Like ordinary String mode, except contiguous spaces are not" + ++ " collapsed. Instead, each space is pushed onto the stack." + p '@' $ "Exit the program with exit code 0 regardless of the number of live IPs in the program." + putStrLn $ fit maxWidth $ "In addition, the following instructions behave as the base Funge-98 instructions:\n" + ++ (intercalate ", " $ map (\c -> '(' : c : ")") " +-*/%!`><^v?_|:\\$.,#gp&~") ++ ".\n" + ++ "Every other instruction reflects. Thus there is no way for an IP to leave Befunge93 mode" + ++ " via the BF93 fingerprint." + diff --git a/Text/Help/Fingerprint/BOOL.hs b/Text/Help/Fingerprint/BOOL.hs new file mode 100644 --- /dev/null +++ b/Text/Help/Fingerprint/BOOL.hs @@ -0,0 +1,18 @@ +module Text.Help.Fingerprint.BOOL ( + help + ) where + +import Text.PrintOption + +----------------------------------------------------------- + +p :: Char -> String -> IO () +p c = printOption ' ' $ " " ++ [c] ++ " --" + +help :: IO () +help = do + p 'A' "Pop Y. Pop X. Push 0 if X is 0. Else push Y." + p 'N' "Pop X. Push 1 if X is 0. Else push 0." + p 'O' "Pop Y. Pop X. Push X if X is not 0. Else push Y." + p 'X' "Pop Y. Pop X. Push 1 if X is 0 and Y not 0 or if X is not 0 and Y is 0. Else push 1." + diff --git a/Text/Help/Fingerprint/BZRO.hs b/Text/Help/Fingerprint/BZRO.hs new file mode 100644 --- /dev/null +++ b/Text/Help/Fingerprint/BZRO.hs @@ -0,0 +1,79 @@ +module Text.Help.Fingerprint.BZRO ( + help + ) where + +import Text.PrintOption + +----------------------------------------------------------- + +p :: Char -> String -> IO () +p c = printOption ' ' $ " " ++ [c] ++ " --" + +maxWidth :: Int +maxWidth = 80 + +line :: IO () +line = putStrLn $ replicate maxWidth '-' + +correspondences :: [(Char, Char)] +correspondences = [ + ('>', '<') + , ('<', '>') + , ('^', 'v') + , ('v', '^') + , ('h', 'l') + , ('l', 'h') + , ('[', ']') + , (']', '[') + , ('_', '|') + , ('|', '_') + , ('(', ')') + , (')', '(') + , ('{', '}') + , ('}', '{') + , ('+', '-') + , ('-', '+') + , ('*', '/') + , ('/', '*') + , ('i', 'o') + , ('o', 'i') + , ('&', '.') + , ('.', '&') + , ('~', ',') + , (',', '~') + , ('g', 'p') + , ('p', 'g') + , ('@', 'q') + , ('q', '@') + , ('\'','"') + , ('"','\'') + ] ++ zip nums (reverse nums) ++ zip alphas (reverse alphas) + where + nums = "0123456789abcdef" + alphas = ['A'..'Z'] + +help :: IO () +help = do + p 'B' "Toggle Bizarro mode." + line + putStrLn "\n ** BIZARRO MODE **\n" + putStrLn $ fit maxWidth $ "In Bizarro mode, the following instructions on the left correspond to the corresponding" + ++ " instruction on the right as if Bizarro mode were not on:\n" + mapM_ (\(x, y) -> putStrLn $ " " ++ [x] ++ " ---> " ++ [y]) correspondences + putStrLn "" + putStrLn $ fit maxWidth $ "Note that if Bizarro mode is on, a (Y) instruction will" + ++ " turn off Bizarro mode and (B) will not due to (Y) corresponding to (B) and vice-versa." + ++ " Also note that the corresponding instructions are not necessarily the base Funge-98" + ++ " instructions. For example, if Hover mode is and was enabled before Bizarro mode (see MODE fingerprint" + ++ " for details on Hover mode), (<) will add 1 the IP's first delta coordinate" + ++ " instead of setting the IP's delta to east (or west for that matter)." + ++ " As with all modes, the most recent mode has priority. As an example, if Bizarro mode" + ++ " is enabled after and while Hover mode is enabled, (<) will subtract 1 from the IP's first delta" + ++ " coordinate. To alleviate any confusion about String mode, if String mode is enabled during Bizarro" + ++ " mode, a (') instruction will push 39 onto the stack, and (\") will disable String mode despite the" + ++ " fact that (') turns on String mode when Bizarro mode is on." + putStrLn $ fit maxWidth $ "\nAll the clarifications above are not special rules. The only rule is that the" + ++ " instructions correspond to other instructions based on symbols, not on semantics. The clarifications" + ++ " assume 'usual' Bizarro mode circumstances, meaning some other mode or instruction is not radically" + ++ " changing the behavior of Bizarro mode, other modes, instructions, and/or the interpreter." + diff --git a/Text/Help/Fingerprint/CPLI.hs b/Text/Help/Fingerprint/CPLI.hs new file mode 100644 --- /dev/null +++ b/Text/Help/Fingerprint/CPLI.hs @@ -0,0 +1,20 @@ +module Text.Help.Fingerprint.CPLI ( + help + ) where + +import Text.PrintOption + +----------------------------------------------------------- + +p :: Char -> String -> IO () +p c = printOption ' ' $ " " ++ [c] ++ " --" + +help :: IO () +help = do + p 'A' "Pop A. Pop B. Pop C. Pop D. Let E+Fi be the complex number (A+Bi)+(C+Di). Push E. Push F." + p 'D' "Pop A. Pop B. Pop C. Pop D. Let E+Fi be the complex number (A+Bi)/(C+Di). Push E. Push F." + p 'M' "Pop A. Pop B. Pop C. Pop D. Let E+Fi be the complex number (A+Bi)*(C+Di). Push E. Push F." + p 'O' "Pop A. Pop B. Output the complex number (A+Bi) followed by a space." + p 'S' "Pop A. Pop B. Pop C. Pop D. Let E+Fi be the complex number (A+Bi)-(C+Di). Push E. Push F." + p 'V' "Pop A. Pop B. Push |A+Bi|. Note |A+Bi| = sqrt(A^2+B^2)." + diff --git a/Text/Help/Fingerprint/FIXP.hs b/Text/Help/Fingerprint/FIXP.hs new file mode 100644 --- /dev/null +++ b/Text/Help/Fingerprint/FIXP.hs @@ -0,0 +1,30 @@ +module Text.Help.Fingerprint.FIXP ( + help + ) where + +import Text.PrintOption + +----------------------------------------------------------- + +p :: Char -> String -> IO () +p c = printOption ' ' $ " " ++ [c] ++ " --" + +help :: IO () +help = do + p 'A' "Pop Y. Pop X. Push the bitwise AND of X and Y." + p 'B' "Pop X. Push 10000*acos(X/10000). Angle is measured in degrees." + p 'C' "Pop X. Push 10000*cos(X/10000). Angle is measured in degrees." + p 'D' "Pop N. Let X be a random number be chosen uniformly from [0, |N|]. If X >= 0 then push N. Else push -N." + p 'I' "Pop X. Push 10000*sin(X/10000). Angle is measured in degrees." + p 'J' "Pop X. Push 10000*asin(X/10000). Angle is measured in degrees." + p 'N' "Pop X. Push -X." + p 'O' "Pop Y. Pop X. Push the bitwise OR of X and Y." + p 'P' "Pop X. Push X*pi." + p 'Q' "Pop X. If X >= 0 then push sqrt(X). Else push X." + p 'R' "Pop Y. Pop X. Push X^B." + p 'S' "Pop X. If X > 0 then push 1. If X < 0 then push -1. Else push 0." + p 'T' "Pop X. Push 10000*tan(X/10000). Angle is measured in degrees." + p 'U' "Pop X. Push 10000*atan(X/10000). Angle is measured in degrees." + p 'V' "Pop X. Push |X|." + p 'X' "Pop Y. Pop X. Push the bitwise XOR of X and Y." + diff --git a/Text/Help/Fingerprint/HRTI.hs b/Text/Help/Fingerprint/HRTI.hs new file mode 100644 --- /dev/null +++ b/Text/Help/Fingerprint/HRTI.hs @@ -0,0 +1,21 @@ +module Text.Help.Fingerprint.HRTI ( + help + ) where + +import Text.PrintOption + +----------------------------------------------------------- + +p :: Char -> String -> IO () +p c = printOption ' ' $ " " ++ [c] ++ " --" + +help :: IO () +help = do + p 'G' $ "Push the smallest clock tick the underlying system can reliably handle, measured in microseconds." + ++ " Results may vary from call to call." + p 'M' "Mark the current IP with a timestamp of the current time." + p 'T' $ "If the current IP has been marked by 'M', push the number of microseconds between the current" + ++ " time and the marked time. Otherwise reverse the IP." + p 'E' "If the current IP has been marked by 'M', remove the mark." + p 'S' "Push the number of microseconds since the last whole second." + diff --git a/Text/Help/Fingerprint/MODE.hs b/Text/Help/Fingerprint/MODE.hs new file mode 100644 --- /dev/null +++ b/Text/Help/Fingerprint/MODE.hs @@ -0,0 +1,18 @@ +module Text.Help.Fingerprint.MODE ( + help + ) where + +import Text.PrintOption + +----------------------------------------------------------- + +p :: Char -> String -> IO () +p c = printOption ' ' $ " " ++ [c] ++ " --" + +help :: IO () +help = do + p 'H' "Toggle Hover mode for the current IP. In Hover mode, the instructions '>', '<', '^', 'v', '|', and '_' treat the IP's delta relatively. That is, instead of setting its dx to 1 and the rest of its delta to 0, '>' would instead simply add 1 to its dx." + p 'I' "Toggle Invert mode for the current IP. When Invert mode is active, cells are pushed on the stack onto the bottom instead of the top." + p 'Q' "Toggle Queue mode for the current IP. When Queue mode is active, cells are popped off the stack from the bottom instead of the top." + p 'S' "Toggle Switch mode. In Switch mode, the pairs of instructions '[' and ']', '{' and '}', and '(' and ')' are treated as switches. When one is executed, the cell it is located in is immediately overwritten with the other instruction of the pair, providing a switching mechanism and a way to seperate coincident IPs." + diff --git a/Text/Help/Fingerprint/MODU.hs b/Text/Help/Fingerprint/MODU.hs new file mode 100644 --- /dev/null +++ b/Text/Help/Fingerprint/MODU.hs @@ -0,0 +1,19 @@ +module Text.Help.Fingerprint.MODU ( + help + ) where + +import Text.PrintOption + +----------------------------------------------------------- + +p :: Char -> String -> IO () +p c = printOption ' ' $ " " ++ [c] ++ " --" + +help :: IO () +help = do + p 'M' $ "Pop Y. Pop X. Push the integer remainder, satisfying [(X `quot` Y)*Y + (X `rem` Y) == X]," + ++ " where quot is integer division truncated toward zero." + p 'U' "Same as 'M', but the pushes the absolute value of the result instead of its signed value." + p 'R' $ "Pop Y. Pop X. Push the integer modulus, satisfying [(X `div` Y)*Y + (X `mod` Y) == X]," + ++ " where div is integer division truncated toward negative infinity." + diff --git a/Text/Help/Fingerprint/NOP.hs b/Text/Help/Fingerprint/NOP.hs new file mode 100644 --- /dev/null +++ b/Text/Help/Fingerprint/NOP.hs @@ -0,0 +1,14 @@ +module Text.Help.Fingerprint.NOP ( + help + ) where + +import Text.PrintOption + +----------------------------------------------------------- + +p :: Char -> String -> IO () +p c = printOption ' ' $ " " ++ [c] ++ " --" + +help :: IO () +help = mapM_ (flip p "Does nothing. Like the 'z' instruction.") ['A'..'Z'] + diff --git a/Text/Help/Fingerprint/NULL.hs b/Text/Help/Fingerprint/NULL.hs new file mode 100644 --- /dev/null +++ b/Text/Help/Fingerprint/NULL.hs @@ -0,0 +1,14 @@ +module Text.Help.Fingerprint.NULL ( + help + ) where + +import Text.PrintOption + +----------------------------------------------------------- + +p :: Char -> String -> IO () +p c = printOption ' ' $ " " ++ [c] ++ " --" + +help :: IO () +help = mapM_ (flip p "Reverse the IP's delta. Like the 'r' instruction.") ['A'..'Z'] + diff --git a/Text/Help/Fingerprint/ORTH.hs b/Text/Help/Fingerprint/ORTH.hs new file mode 100644 --- /dev/null +++ b/Text/Help/Fingerprint/ORTH.hs @@ -0,0 +1,28 @@ +module Text.Help.Fingerprint.ORTH ( + help + ) where + +import Text.PrintOption + +----------------------------------------------------------- + +p :: Char -> String -> IO () +p c = printOption ' ' $ " " ++ [c] ++ " --" + +help :: IO () +help = do + p 'A' "Pop Y. Pop X. Push the bitwise AND of X and Y." + p 'O' "Pop Y. Pop X. Push the bitwise OR of X and Y." + p 'E' "Pop Y. Pop X. Push the bitwise XOR of X and Y." + p 'X' "Pop X. Set the IP's position's x coordinate to X." + p 'Y' "Pop Y. Set the IP's position's y coordinate to Y." + p 'V' "Pop X. Set the IP's dx to X." + p 'W' "Pop Y. Set the IP's dy to Y." + p 'G' $ "If the dimension < 2 then reverse. Otherwise do the following: Pop Y. Pop X. Retrieve the value in" + ++ " funge space at the coordinates (X,Y). Push that value. If the dimension > 2, then the higher" + ++ " dimension coordinates are 0." + p 'P' $ "If the dimension < 2 then reverse. Otherwise do the following: Pop Y. Pop X. Pop V. Place the value V in" + ++ " funge space at the coordinates (X,Y). If the dimension > 2, then the higher dimension coordinates are 0." + p 'Z' "Pop X. If X = 0, then trampoline (as in a '#' instruction). Else do nothing (as in a 'z' instruction)." + p 'S' "Output a 0 terminated string: Pop X. If X = 0 then do nothing. Else output X as a character and repeat." + diff --git a/Text/Help/Fingerprint/REFC.hs b/Text/Help/Fingerprint/REFC.hs new file mode 100644 --- /dev/null +++ b/Text/Help/Fingerprint/REFC.hs @@ -0,0 +1,35 @@ +module Text.Help.Fingerprint.REFC ( + help + ) where + +import Data.Int + +import Text.PrintOption + +----------------------------------------------------------- + +p :: Char -> String -> IO () +p c = printOption ' ' $ " " ++ [c] ++ " --" + +maxWidth :: Int +maxWidth = 80 + +num32BitVals :: Integer +num32BitVals = fromIntegral maxB - fromIntegral minB + where + maxB = maxBound :: Int32 + minB = minBound :: Int32 + +help :: IO () +help = do + p 'R' $ "Pop a vector off the stack. Push a scalar onto the stack unique to that vector. If 'R' is called multiple" + ++ " times with equivalent vectors, each one gets a different unique scalar. Should the interpreter run out" + ++ " of unique values, an error message will be emitted, and the program will end. The number of unique values" + ++ " is equivalent to the number of values the funge cell size can acquire. For example, if 32 bit integers" + ++ " are used, 'R' can be used safely " ++ show num32BitVals ++ " times." + p 'D' $ "Pop X. If X corresponds to a vector via the 'R' instruction, push that vector onto the stack." + ++ " Otherwise reverse the current IP (X is still popped)." + putStrLn $ fit maxWidth $ "Note that the memory used to keep these correspondences are never freed" + ++ " during the execution of the program. Hence if used enough, it is more likely that the program will fail" + ++ " due to too much memory being used than not being able to create a new unique value." + diff --git a/Text/Help/Fingerprint/ROMA.hs b/Text/Help/Fingerprint/ROMA.hs new file mode 100644 --- /dev/null +++ b/Text/Help/Fingerprint/ROMA.hs @@ -0,0 +1,21 @@ +module Text.Help.Fingerprint.ROMA ( + help + ) where + +import Text.PrintOption + +----------------------------------------------------------- + +p :: Char -> String -> IO () +p c = printOption ' ' $ " " ++ [c] ++ " --" + +help :: IO () +help = do + p 'C' "Push 100 onto the stack." + p 'D' "Push 500 onto the stack." + p 'I' "Push 1 onto the stack." + p 'L' "Push 50 onto the stack." + p 'M' "Push 1000 onto the stack." + p 'V' "Push 5 onto the stack." + p 'X' "Push 10 onto the stack." + diff --git a/Text/Help/Fungi.hs b/Text/Help/Fungi.hs --- a/Text/Help/Fungi.hs +++ b/Text/Help/Fungi.hs @@ -44,8 +44,11 @@ (d, m) = x `divMod` 256 line :: IO () -line = putStrLn $ replicate 80 '-' +line = putStrLn $ replicate maxWidth '-' +maxWidth :: Int +maxWidth = 80 + help :: IO () help = do line @@ -54,6 +57,8 @@ line putStrLn $ "Options:" p '?' "help" "Display this help message." + p ' ' "version" "Display version." + p ' ' "finger-doc NAME" "Display documentation for the fingerprint with name NAME." b 'd' "debug [MODE=1]" $ concat [ "Run program using debugger." , "***MODE=1,on,true: Run debugger in step mode." @@ -84,5 +89,11 @@ ] line p ' ' "FINGERPRINTS--" fingers + line + putStrLn $ fit maxWidth $ "There is also the +RTS option if Fungi was compiled via the GHC" + ++ " (Glaskow Haskell Compiler). This option deals with run time options of the program and is not determined" + ++ " by Fungi. Using this option may improve performance of Fungi. However, this option" + ++ " (and options related to +RTS) is beyond the scope of this program. See GHC documentation" + ++ " for more details." line diff --git a/Text/PrintOption.hs b/Text/PrintOption.hs --- a/Text/PrintOption.hs +++ b/Text/PrintOption.hs @@ -5,9 +5,10 @@ , showOption , PrintSettings (..) , defaultPrintSettings + , fit ) where -import Data.List (stripPrefix) +import Data.List (stripPrefix, groupBy) ----------------------------------------------------------- @@ -129,4 +130,35 @@ printOption :: Char -> String -> String -> IO () printOption = printOptionWith defaultPrintSettings + +fit :: Int -> String -> String +fit maxWidth = fit' 0 . filter (/= " ") . groupBy (\x y -> all (`notElem` [x, y]) " \n") + where + fit' :: Int -> [String] -> String + fit' n strs' = case strs' of + [] -> "" + [str] -> let len = length str + in case str of + "\n" -> "\n" + _ -> if n == 0 && len >= maxWidth + then str + else if n + len > maxWidth + then '\n' : str + else str + (str:strs@("\n":_)) -> let len = length str + in case str of + "\n" -> '\n' : fit' 0 strs + _ -> if n == 0 && len >= maxWidth + then str ++ fit' 0 strs + else if n + len > maxWidth + then '\n' : str ++ " " ++ fit' (len + 1) strs + else str ++ fit' (n + len) strs + (str:strs) -> let len = length str + in case str of + "\n" -> '\n' : fit' 0 strs + _ -> if n == 0 && len >= maxWidth + then str ++ "\n" ++ fit' 0 strs + else if n + len + 1 > maxWidth + then '\n' : str ++ " " ++ fit' (len + 1) strs + else str ++ " " ++ fit' (n + len + 1) strs diff --git a/Version.hs b/Version.hs --- a/Version.hs +++ b/Version.hs @@ -9,5 +9,5 @@ handprint = 378447798 version :: String -version = "1.0.2" +version = "1.0.3" diff --git a/runTests.bash b/runTests.bash new file mode 100644 --- /dev/null +++ b/runTests.bash @@ -0,0 +1,1 @@ +runhaskell Tester.hs diff --git a/tests/bad/execute.bf b/tests/bad/execute.bf new file mode 100644 --- /dev/null +++ b/tests/bad/execute.bf @@ -0,0 +1,1 @@ +nff6++ v + I diff --git a/tests/bool.bf b/tests/bool.bf new file mode 100644 --- /dev/null +++ b/tests/bool.bf @@ -0,0 +1,2 @@ + n23A n04A n40A n00A n23O n04O n40O n00O n23X n04X n40X n00X @ diff --git a/tests/good/concurrent.bf b/tests/good/concurrent.bf new file mode 100644 --- /dev/null +++ b/tests/good/concurrent.bf @@ -0,0 +1,2 @@ +#vt@ + @ diff --git a/tests/good/concurrent2.bf b/tests/good/concurrent2.bf new file mode 100644 --- /dev/null +++ b/tests/good/concurrent2.bf @@ -0,0 +1,2 @@ +#vt 0q + > 1@ diff --git a/tests/good/direction.bf b/tests/good/direction.bf new file mode 100644 --- /dev/null +++ b/tests/good/direction.bf @@ -0,0 +1,6 @@ +v1q q + 1 + q0 < +> ^1q +1 +q diff --git a/tests/good/execute.bf b/tests/good/execute.bf new file mode 100644 --- /dev/null +++ b/tests/good/execute.bf @@ -0,0 +1,1 @@ +@q@@@@@@ diff --git a/tests/good/fingers/bzro/goEast.bf b/tests/good/fingers/bzro/goEast.bf new file mode 100644 --- /dev/null +++ b/tests/good/fingers/bzro/goEast.bf @@ -0,0 +1,1 @@ +"ORZB"4(n1B#@"ORZB"4(nB' '"Y''w' w' w1q + 1 1 1 + q q q diff --git a/tests/good/fingers/bzro/turnOffBizarro.bf b/tests/good/fingers/bzro/turnOffBizarro.bf new file mode 100644 --- /dev/null +++ b/tests/good/fingers/bzro/turnOffBizarro.bf @@ -0,0 +1,2 @@ +"ORZB"4(nB#^B1q + q0qq diff --git a/tests/good/goAway.bf b/tests/good/goAway.bf new file mode 100644 --- /dev/null +++ b/tests/good/goAway.bf @@ -0,0 +1,23 @@ +> v < + : + 7 + j + + +^ 1< +^ _^ + - + 0 +^ < < + |-3 ? 1-| + 0 2 + q 2 > ^ + - +^ _v +^ 3< + + + + + + diff --git a/tests/good/inputFile.bf b/tests/good/inputFile.bf new file mode 100644 --- /dev/null +++ b/tests/good/inputFile.bf @@ -0,0 +1,6 @@ +qqqqqqqqqqqqqq + qqqqqqqqqqqqqqq + qqqqqqqqqqqqqqq + qqqqqqqqqqqqqqq + qqqqqqqqqqqqqqq diff --git a/tests/good/inputFile.dat b/tests/good/inputFile.dat new file mode 100644 --- /dev/null +++ b/tests/good/inputFile.dat @@ -0,0 +1,3 @@ +v +z +>zzzz0q diff --git a/tests/good/jumpForward.bf b/tests/good/jumpForward.bf new file mode 100644 --- /dev/null +++ b/tests/good/jumpForward.bf @@ -0,0 +1,7 @@ +11jv2jvv3jvvv v +>>>>>>>>>>>>>>1q + > v +>>>>>>>>>>>>>>>v>5jvvvvv^>>>>>>>>>>>>>>>>v>>>>>1q1<>0f-j>>>>>>>>>>>>>>>11 + 1 >>>>>1q1<<<<<<<<<<<<<< ^^^^^<<<< + q1<<<<<<<<<<<<<<<<<<<<<<<<>10j0q1<<<<<<<<<<<<<<<<<<<<<< + ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< diff --git a/tests/good/jumpOver.bf b/tests/good/jumpOver.bf new file mode 100644 --- /dev/null +++ b/tests/good/jumpOver.bf @@ -0,0 +1,2 @@ +;;1;;1; v ;0q + > 1q diff --git a/tests/good/math.bf b/tests/good/math.bf new file mode 100644 --- /dev/null +++ b/tests/good/math.bf @@ -0,0 +1,4 @@ +15+4-3*6/6+4%3-v>1q1 < < + >| >1!| + >!| >07-!| + q1< >0q diff --git a/tests/good/quit.bf b/tests/good/quit.bf new file mode 100644 --- /dev/null +++ b/tests/good/quit.bf @@ -0,0 +1,1 @@ +q diff --git a/tests/good/stop.bf b/tests/good/stop.bf new file mode 100644 --- /dev/null +++ b/tests/good/stop.bf @@ -0,0 +1,1 @@ +@ diff --git a/tests/good/trampoline.bf b/tests/good/trampoline.bf new file mode 100644 --- /dev/null +++ b/tests/good/trampoline.bf @@ -0,0 +1,3 @@ +#v# # 0q + 1 + q diff --git a/tests/good/turn.bf b/tests/good/turn.bf new file mode 100644 --- /dev/null +++ b/tests/good/turn.bf @@ -0,0 +1,7 @@ +v + + vvvvvvvvvv<< + >> ]^ +> #^[vvvvvvvvvv0^ + ^1<<<<<<<<< ^ + + + + 0q > + diff --git a/tests/mode.bf b/tests/mode.bf new file mode 100644 --- /dev/null +++ b/tests/mode.bf @@ -0,0 +1,2 @@ +HIQS"HELLO!!!"@ diff --git a/tests/mycology/license.txt b/tests/mycology/license.txt new file mode 100644 --- /dev/null +++ b/tests/mycology/license.txt @@ -0,0 +1,24 @@ +Copyright (c) 2006-2008, Matti Niemenmaa +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 the project nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. diff --git a/tests/mycology/mycology.b98 b/tests/mycology/mycology.b98 new file mode 100644 Binary files /dev/null and b/tests/mycology/mycology.b98 differ diff --git a/tests/mycology/mycorand.bf b/tests/mycology/mycorand.bf new file mode 100644 --- /dev/null +++ b/tests/mycology/mycorand.bf @@ -0,0 +1,16 @@ +p4v p00+1g00 <<<<< v< + #> : | ," + > 1- :2+"^"\7p "^"32p: | ,t + v? 1- :2+">"\7p "^"33p: | ,i + > 1- :2+"v"\7p "^"34p: | ,m + > 1- :2+"<"\7p "^"35p:| ,e +v +55<<<<< p6+1*36*88p6*54-1*95<" +>" redro eht ni detareneg erew snoitcerid ehT">:#,_" tem saw ?">:#,_g1+."s"^ + +After going in a direction: + Subtract one from the counter + Place >^v<, according to which direction was taken, in the string + Setup the following being done every time this path is taken again, then do it: + If the counter is zero, output the number of tries needed and the order of >^v< and stop + Add one to the number of tries needed + Go back to the ? diff --git a/tests/mycology/mycoterm.b98 b/tests/mycology/mycoterm.b98 new file mode 100644 --- /dev/null +++ b/tests/mycology/mycoterm.b98 @@ -0,0 +1,57 @@ +a".deneppah evah dluohs tahw fo noitpircsed dna desu dnammoc eht fo yltsom"v +v $_,#! #:<"All these tests are purely I/O related: output will consist "< + +> "MRET"4#v(na"...eunitnoc ot retne sserP"a".dedaol MRET">:#,_~$#vCv +v"loaded."< v "BAD: C reflected"an< +>" ton MR"v v "C was called, the screen should have cleared."a< +v "TE"< >:#,_a"...D-20 gnillaC"a>:#,_02-#vDa"enil D-20 eht evoba "v +>:#,_$v v_,#! #:<;#"It reflected"an< ;"This should be right"< +v ,a< >a"...D1 gnillaC"a>:#,_1#vDa"siht evoba enil knalb "v + v_,#! #:<;#"BAD: it reflected"an< ;"There should be a"< + >a"...G4f gnillaC">:#,_f3#vGaaaa"enil D1 eht fo thgir eht "v + va_,#! #:<;#"BAD: it reflected"an<;"This should be placed by G to"< + >"...eunitnoc ot retne sserp ,SU5 htiw hpargarap dnoces eht r"v + v"second paragraph was"aa Sv#Uv#5$~_,#! #:;# "BAD: S reflected"a< ;v + >" eht erehw eb won dluohs sihT" >:#,_a"...eunitnoc ot retne sserp"v + vaaaaaaaaLv#Hv#$~_,#! #:<"Trying to clear the first line with HL, "< + >na"detcelfer H :DAB" v + > na"detcelfer L :DAB" v + >"saw enil tsrif eht erehw eb won dluohs sihT">:#,_v +v < +> "SRCN"4#v(na".dedaol SRCN">:#,_a"...eunitnoc ot retne sserp ,I1 gnillaC"a".nees eb lliw gnihton"v +v"loaded."< v", might not work after I: using S instead, so if R and S don't work, "< +>" ton SR"v >:#,_~$ 1#vIa"...S gnitseT"#@Sa"...gniunitnoc"v +v "NC"< v"BAD: 1I reflected, can't test the rest"an< v S"S didn't reflect, "< +> >:#,_a,@ >a"...R gnitseT"S#@Ra"tuptuo eb "v + >na"stcelfer P :DAB" v + vPPPPPPPPPPPPPPPPPPPPPPPPPPPPP^#"If this is visible, P works."aRS"R didn't reflect, there should"< + >na".krow t'nseod P ,deraeppa P tuoba egassem on fI">S v + + v"Some sort of beep should have resulted."aRBv# S"Testing B..."a< + v "BAD: B reflected"an < + + >SR0#vE 0#vN >a"neercs eht ot deohce eb t'ndluohs yek eht dna retne sserp ot deen"v + >na"stcelfer E0 :DAB"S^S na"stcelfer N0 :DAB"^>SR#vG a\ >:!#v_:a%'0+\v + v"BAD: G reflected"an< ^ /a < <- . might not work: int to string + v RS< "Got "$< also used below + + >'x#vU #vG 'x-#v_a"021 si GUx' :DOOG" >SR 1#vK >a"...eunitnoc ot yek noitcn"v + > na"detcelfer Ux' :DAB" ^ >na"stcelfer K1 :DAB"S^ vGv#RS"Press any fu"< + >a"detcelfer GUx' :DAB" ^ v"BAD: G reflected"an< + >na"021 t'nsi GUx' :DAB"^ >\ >:!#v_:a%'0+\v + vMv#00G RS"Going to test M, press enter to continue..."RS<"Got "$ ;^ ;<;/a < + >na"C tset t'nac ,stcelfer M :DAB" v + >a"neercs eht fo pot eht ta eb dluohs sihT"SR 2#vCa"deraelc evah dluohs neercs eht fo tser ehT"v + # + v"changed"aCv#1M22GRSa"Trying to overwrite above with M and C, press any key to continue..."aRS< + # # + >" evah dluohs enil si"SRa"eunitnoc ot yek yna sserP"SR0#vCa"deraelc evah dluohs neercs elohw "v + v < v "The"< + > v + > > >na"detcelfer C :DAB"v + v"Press any key to try to end curses mode..."aRS< + >SRGn#vIa"dekrow I0 :DOOG">:#,_@ + @RS"BAD: 0I reflects"an< diff --git a/tests/mycology/mycotrds.b98 b/tests/mycology/mycotrds.b98 new file mode 100644 --- /dev/null +++ b/tests/mycology/mycotrds.b98 @@ -0,0 +1,64 @@ +1y2%!#v_"SDRT"4 #v(na".SDRT dedaoL">:#,_ a"..."v v"Need Befunge-98."+550 + >na"SDRT tset t'nac ,tnerrucnoc ton smialc y1 "$ >:#,_@ + >na".dedaol ton SDRT" ^ +vp22_,#! #:<"Splitting IP, concurrency better work"< +>122#vt#vSg\$#v_a"krow ot smees S :DOOG">:#,_'v65p#vC22g!#v_a"skrow C :DOOG" v + >p@ >a"krow t'nseod S :DAB"v >na"stcelfer C :DAB">:#,_@ + p >na"stcelfer S :DAB" >:#,_ v $ +v @ >a"krow t'nseod C :DAB">:#,_n + # +>a"...emit seunitnoc deppots si emit elihw PI eht gnitanimret fi gnikcehC">:#,_ #vtS@ +v"in case of failure, q will be used to quit."a _,#! #:<"GOOD: apparently it does"a< +>" ...levart emit tset ot gnitratS"a>:#,_a".detaeper eb t'ndluohs nurer eht gnirud tuptuo ,orez tniop"v +v a"But note that if jumping backwards in time is implemented as rerunning from "< +>".desufnoc si reterpretni eht ,seilamona rehto era ereht ro segnahc tuptuo eht fo yna fI " v +v_,#! #:<"Much of the output up to and after now, including this, will be output many times."< + +>#vt>< v v _,#! #:<"GOOD: 01-0V didn't reflect"aVv#0-1 _,#! #:< + >"SDRT"4(n f6*aa+#vDa"tcelfer t'ndid D+aa*6f :DOOG">:#,_8d9a+** #vTa"tcelfer t'ndid T**+a9d8 :DOOG"^ + ; >na"detcelfer D+aa*6f :DAB">:#,_q >na"detcelfer T**+a9d8 :DAB">:#,_q +>na"ylreporp emit hguorht pmuj t'nseod J :DAB" ^ > na"detcelfer V0-10 :DAB"^< : +|!g11_,#! #:<"GOOD: stack retained after J"a _v# ,k*b2pe2$'zzzz"GOOD: J jumps in space"a v#< " + ^"BAD: stack not retained after J"an< >;#_,#! #:<"BAD: V doesn't work"a0<;^ B +>a"emit hguorht pmuj ot sraeppa J :DOOG">:#,_#vI>a"..gnipmuj ,tcelfer t'ndid I :DOOG"3b*k, #vJ A + ; > na"detcelfer I :DAB" #D^ + v$ < q_,#! #:<"BAD: J reflected trying to jump back to the future"an< : + + >#vG0" dehsup G :FEDNU">:#,_$.a")6985 eb dluohs ,DOOG saw gnihtyreve fi(">:#,_11pv " + >na"stcelfer G :DAB" >:#,_$zzzz1111111111111111111111111111111111111111>:#$_11pv + >na"pmuj detnaw od tonnac ,egral oot si P :DEFNU" ^ +v"jumping to tick 1976..."a_^#!`\ ,a. zzz,kd"UNDEF: P gave ":Pv# *+**9ad13< +>" ,enif si lav-P :DOOG"4b*k,zz 1#vJv >na"stcelfer P" ^ + X > >na"detcelfer J" ^ +v_,#! #: na"stcelfer R" ^ +>^ > na"detcelfer E10" ^ < +R >na"detcelfer U-*:*aa0"^ +>a"tcelfer t'ndid R :DOOG">:#,_1-#^Ea"tcelfer t'ndid E-100 :DOOG">:#,_aa*:*-#^U0a"tcelfer t'ndid U-*:" v +v"d end up at the time that P gave..."a_v#!`+*8รณ'\,a.,kd"UNDEF: P gave ":Pp+885: '_,#! #:<"GOOD: 0aa*" < +' >na"pmuj detnaw od tonnac ,egral oot si P :DEFNU" ^ +l 012p@ +>"uohs ,00001- kcit ta @ a ot gnipmuj ,enif si lav-P :DOOG"8a*c+k,#vJ; + " @ > ^ > ^ << + >12g#^_n"$"d5*85*pzzv +vzzzzzzzzzzzzzzzzzzzzzzzzzzz< +>a"dedeeccus evah ot sraeppa emit tseilrae eht ot pmuj :DOOG"a>:#,_#vt"SDRT"4(nzzzzzzzzzzzzzzzv ; +v"from being born..."a_^#!`\,a. zzz,kd"UNDEF: P gave ":P T:**+*aa789>#;"SDRT"4(n#;< z J^#E40T< + "estroyed the t instruction that made me, setting Tardis with T and E and jumping back..."" fles tneverp ot 4077 kcit ot gniog ,enif si lav-P :DOOG"7a*4+k,z#vJ' 7a*1-4b*p'$d5*4b*pa^>z k,79bc***^ +zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz$>#zzzzzzzzzzzzzzzzzzzzzz #< ^ ; v +v"er back to wait for the first to arrive..."a ,k*57azz "GOOD: got back and am still alive."a< 5 +>"htruf pmuj rehtona dna ,kcab pmuj ot tuoba PI enO"9a*1+k,zzzz 77abb***+ T 169*D v a +vzz "GOOD: P-val is fine for both jumps..."a_v#!`\,a. zzz,kd"UNDEF: P gave ":P ***dda5 < d +>73a*+k,#vJ >zzzzzzzzzzzzzzzzzzzzzzzzv >na"pmuj detnaw od tonnac ,egral oot si P :DEFNU">:#,_ q d + > #^zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz#< > > ^ * + 132pa".pmuj ts1 diD"dk,zzz @ >a"emit no devirra PI ts1 :DOOG"47*zzzz]"Doing 2nd jump..."aD*b51T**< + >032p'$:74d*p29a*+87*pzzzzzzzzzz32g|z > >k,I#^J +v; >a"emit no evirra t'ndid PI ts1 :FEDNU"57*zzzz^; J^# $_,#! #:$$zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz^ + >zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz^ + +>a"...89b.sdrtocym gnitixe ,enod llA"aa".enif si emit dnoces eht ylno gnivirra tI"v +v "Note that if the first IP didn't arrive on time both times, that is BAD."a< +>a"gnitset PI elpitlum morf denruter :DOOG"a>:#,_@ diff --git a/tests/mycology/mycouser.b98 b/tests/mycology/mycouser.b98 new file mode 100644 --- /dev/null +++ b/tests/mycology/mycouser.b98 @@ -0,0 +1,25 @@ +92#v/4-#v_55+"4 = 2 / 9 :DOOG">:#,_92#v%1-#v_55+"1 = 2 % 9 :DOOG">:#,_ vv$$$$$$< + >055+ "stcelfer / :DAB" ^>'",,@ >055+ "stcelfer % :DAB" ^ 5>$$$ v$ + >055+"4 =! 2 / 9 :DAB"^^ a_,#! #:<;>055+"1 =! 2 % 9 :DAB"^;< 5v" wo"<$ +v,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,"About to test division by zero..."+<>",de"v$ +>10#v/#v_055+"0 = 0 / 1 :DOOG" >:#,_ 10#v% #v_055+"0 = 0 % 1 :DOOG"v "$ + >05 5+"...)llits( stcelfer /"^ $0 $0"UNDEF: 1 / 0 != 0," < d$ + >055+"noisivid 89-egnuF tcerrocni r"# "o " "nevig rewsna gnorw "^ a" +v"answer given or incorrect Funge-98 division"+55< > >:#,_#<#< #ov + < >55+"stcel"v>55+"...)llits( stcelfer %"^v^ "" +>" gnorw ,0 =! 0 % 1 :FEDNU"^ @_,#! #:< # *25"UNDEF: STRN fingerprint not l":#,_#^&0" tog :FEDNU">:#,_$.$55+".tcerroc " v> +"yllufepoh si hcihw">:#,_ v >"fer & :DAB"55+".dnim reveN">:#,_v > +>:#,_v#:"Please input a character: "< < X + v < >#v~0" tog :FEDNU">:#,_$:."'",,$55+".tcerroc yllufepoh si hcihw '">:#,_ v +#v~^ v>55+"stcelfer ~ :DAB"55+".dnim reveN" >:#,_ > + > ">:#,_@" $$$$$$$ 52*:"~ & % / :snoitcurtsni gniwollof eht gnikcehc enod llA"v +v55_,#! #:<"Loaded BASE fingerprint: testing I instruction."an(v#4"BASE"_,#! #:< + #:<"UNDEF: BASE fingerprint not loaded, won't check I."*520< >:#,_@ v _,#! ++ ;^>0\"detcelfer I :DAB"; x3*a5 a"BAD: & reflected. Never mind..."\0< # +>"...krow snoitcurtsni 89-egnufeB gnimussA">:#,_" ?ni tupni daer ot esab hcihW"v +v # "Input a number in that base: "0,a.:$_,#! #:<"Selected base "\&^#_,#! #:< +>:#,_$#vI\" tog :FEDNU">:#,_$.a".tcerroc yllufepoh si hcihw">:#,_$ v$_,#! #:<" +v".."an<;a"BAD: I reflected"a"As 10I should probably " ".esab dilav a rof tcelfer t'ndluohs I ,& ekil evaheb"^>' v>025*".I kcehc t'n"^ + '"'I^# _,#! #: Go East + 1 118 v Go South + 2 60 < Go West + 3 94 ^ Go North + 4 36 $ Pop Explicitly testing whether popping an + empty stack works as it should is + done separately, later. + + 5 34 " Toggle Stringmode If no reflection on the instruction + occurs, but the string's contents are + interpreted as instructions, a second + "4 " is output before exiting. + + 6 95 _ East-West If If the comparison is done incorrectly + (i.e. the wrong direction is taken) + an additional "5 " is output. + + 7 43 + Add + +For example, if the interpreter emits only "0 1 ", the Go East and Go South +instructions were correctly interpreted, but a reflection occurred upon meeting +Go West. A conforming interpreter should output every code in the listing once. + +These tests are very simple, due to the basic nature of the instructions +involved. All that is tested is whether a reflection occurs or not. If +mycology.b98 claims that an instruction which appears to work perfectly is +failing, make sure that the above do what they should. + +Having tested the above, mycology.b98 tests the Output Character instruction +and hence reverts to plain English output. If there is no output after code 7, +the Output Character instruction does not function as it should. + +The output format changes to lines beginning with "BAD:" or "GOOD:", followed +by a description of what the interpreter does wrong or correctly, respectively. +Some, but not all, "BAD" lines are followed by a Stop instruction - these tend +to be features which are deemed useful enough that they are used later in the +program. (Or, possibly, features which may be used later, but aren't: it's hard +to modify Befunge source code after it's first written, so there may be some +cases where a Stop isn't necessary but is there anyway.) In some cases, a Stop +was added to simplify the code: the Befunge-93 area is particularly snarly, +since space is at a premium. + +Some lines begin with "UNDEF:". This means that the specification is either +ambiguous or completely ignorant of an issue, and so different possibilities +are acceptable. It is possible that some such undefined cases may result in +"BAD:" if the interpreter does something completely unexpected, but there is no +"GOOD:" equivalent, only "UNDEF:". + +Some comment lines not beginning with "BAD:", "GOOD:", or "UNDEF:" are also +emitted occasionally, in order to clarify what is going on. + +Other notes on mycology.b98: + + Befunge-93 detection relies on the interpreter using only the first 80 + characters of lines, since Befunge-93 has a Funge-Space of 80x25 cells. + + The checks are generally very simple. For instance, if the Subtract or + Multiply instructions empty the stack, they will be considered to work + properly: only a few checks are done, and they all check for zero. + + Instructions are assumed to work if they pass one test (for the more + complicated instructions, more tests are needed, but every behaviour of the + instruction is still tested only once). If, for instance, an instruction + works the first 41 times and randomly fails every third time after that, + Mycology will probably not detect it, but will silently fail or, in the + worst case, pass. + + Instructions are assumed to be at least somewhat sane: e.g. | should either + reflect or pop a cell and cause the IP to start moving north or south. Not + east or west, or to teleport to a random location in Funge- Space, or push + 72 ampersands onto the stack. It is the tester's responsibility, not + Mycology's, to make sure that the interpreter doesn't go crazy and perform + malicious acts. You use Mycology at your own risk. + +See the end of this file for notes on particular messages. + +The following instructions are _not_ tested by mycology.b98 (those preceded by +an asterisk are tested if the interpreter is detected as supporting +Befunge-98): + +Decimal ASCII Instruction + + 37 % *Remainder + 38 & Input Decimal + 47 / *Divide + 61 = Execute + 63 ? *Go Away + 126 ~ Input Character + +The division and input instructions are tested in mycouser.b98 because they all +require user intervention (the division instructions only when dividing by +zero, but I felt it would be better to not split the testing of an instruction +into two files). Their correct behaviour is also very difficult to verify +without a knowledgeable user. + +Go Away is tested separately in mycorand.bf because it takes too much space to +fit in the Befunge-93 area of mycology.b98. If the Befunge-98 instruction Input +File works, mycorand.bf is loaded using it and Go Away is thus tested in +mycology.b98. + +Execute is completely untested, because to get a reliable result would require +testing various commands and noting their behaviours on different platforms. An +educated guess regarding the user's platform is in order, and overall it would +be too complicated. It is simplest to test this manually, rather than to try to +cater for all cases in a suite such as Mycology. + +Implementation notes regarding mycorand.bf: + + Beware! If Go Away is unimplemented and thus reflects, an infinite loop + is entered! + + The testing is very simple: it is only made sure that Go Away causes the + instruction pointer to go at least once in every cardinal direction, + though it is always encountered from the same direction. + + The number of tries it took to successfully go in every direction is + output, so an interpreter's implementer can make sure the number + fluctuates somewhat. The order in which the directions were generated is + also output, so that it can be verified that the order isn't always the + same. + +Make sure that the interpreter successfully passes the Befunge-93 area of +mycology.b98 before loading mycorand.bf or mycouser.bf! + +Regarding fingerprints +---------------------- + +mycology.b98 tests every fingerprint that I am aware of, apart from FNGR, SGNL, +and WIND. It is completely up to the interpreter's writer(s) whether any should +be supported: a completely specification-conforming interpreter does not need +to support any fingerprint at all, as long as the ( "Load Semantics" and ) +"Unload Semantics" instructions perform correctly. + +FNGR is not tested because its specifications contradict the Befunge-98 +specifications. It contains operations for performing on a single fingerprint +stack, but the specifications for Befunge-98 state that there should be a stack +of semantics for each instruction in the range [A, Z]. RC/Funge-98, the (only, +as far as I know) interpreter implementing FNGR, fails some of Mycology's tests +due to this. + +SGNL is not tested simply because it is platform-specific. There is no +technical obstacle to it, only my own convictions regarding platform-specific +code. If anybody wishes to write code to test it, feel free to send it to me, +it may be worthy of addition to Mycology. + +WIND is not tested because I do not wish to support it in my interpreter, and +thus I didn't feel like writing tests for it. RC/Funge-98 is the only +interpreter supporting it, and if I had discovered any bugs in it I would have +had to delve into unfamiliar code to make it even possible to test the whole +thing. I decided it was too much work and left it out. Once again, the addition +of WIND to Mycology is perfectly fine, but I won't be the one to write the +code. + +The list of fingerprints which are tested: + + Official Cat's Eye Technologies fingerprints: + + "HRTI" 0x48525449 High-Resolution Timer Interface + "MODE" 0x4d4f4445 Funge-98 Standard Modes + "MODU" 0x4d4f4455 Modulo Arithmetic Extension + "NULL" 0x4e554c4c Funge-98 Null Fingerprint + "ORTH" 0x4f525448 Orthogonal Easement Library + "PERL" 0x5045524c Generic Interface to the Perl Language + "REFC" 0x52454643 Referenced Cells Extension + "ROMA" 0x524f4d41 Funge-98 Roman Numerals + "TOYS" 0x544f5953 Funge-98 Standard Toys + "TURT" 0x54555254 Simple Turtle Graphics Library + + RC/Funge-98 fingerprints: + + In all cases, the documentation is considered the primary source of how + an instruction should behave. Precise semantics have been inferred from + the RC/Funge-98 source code where not properly documented. + + For all fingerprints involving vectors, RC/Funge-98 doesn't, for some + reason, use the IP's storage offset. Thus, the tests assume the same + behaviour. + + "3DSP" 0x33445350 3D space manipulation extension + "BASE" 0x42415345 I/O for numbers in other bases + "CPLI" 0x43504c49 Complex Integer extension + "DATE" 0x44415445 Date functions + "DIRF" 0x44495246 Directory functions extension + "EVAR" 0x45564152 Environment variables extension + "FILE" 0x46494c45 File I/O functions + "FING" 0x46494e47 Operate on single fingerprint semantics + "FIXP" 0x46495850 Some useful math functions + "FPSP" 0x46505350 Single precision floating point + "FPDP" 0x46504450 Double precision floating point + "FRTH" 0x46525448 Some common forth [sic] commands + "IIPC" 0x49495043 Inter IP [sic] communicaiton [sic] extension + "IMAP" 0x494d4150 Instruction remap extension + "INDV" 0x494e4456 Pointer functions + "REXP" 0x52455850 Regular Expression Matching + "SOCK" 0x534f434b tcp/ip [sic] socket extension + "STRN" 0x5354524e String functions + "SUBR" 0x53554252 Subroutine extension + "TERM" 0x5445524d Terminal control functions + "TIME" 0x54494d45 Time and Date functions + "TRDS" 0x54524453 IP travel in time and space + + Jesse van Herk's extensions to RC/Funge-98: + + "JSTR" 0x4a535452 + "NCRS" 0x4e435253 Ncurses [sic] extension + + GLFunge98 fingerprints: + + "SCKE" 0x53434b45 + +Notes on particular messages output by mycology.b98 +--------------------------------------------------- + +"UNDEF: # across left edge..." +.............................. + +Here, the line and file cases are considered separately. This is because some +interpreters consider the Funge-Space as a rectangle: see below, using 0 to +mark empty cells which are outside Funge-Space. + +> v000 +v > > +@00000000 + +Even though the file doesn't contain the three spaces at the end of the first +line, or any of the spaces at the end of the third line, the program's +representation of Funge-Space does, because Funge-Space is padded out to the +width of the longest line in the file. + +Because jumping across the edge of Funge-Space isn't mentioned in the +specification, one cannot be sure as to what should happen. If it is considered +that Funge-Space is infinitely surrounded by spaces, jumping across the edge of +space shouldn't skip over anything. On the other hand, # jumps over "the next +Funge-Space cell in [the instruction pointer's] path", which might not include +this void. + +However, it may be that an existing space cell which is not part of this void +is skipped over. Thus, both jumping over the edge of the physical edge of the +file, with only the void in between, and jumping over the edge of a line which +is shorter, but may contain the spaces as the 0s in the above example, are +tested. Most interpreters have different behaviour for the two. + +"BAD: 101-{} doesn't leave stack top as 0 and next as 1" +........................................................ + +This is something which may be tricky to get right. Let's examine what happens. +On each following line, the instruction comes first, followed by the stack +stack, with the contents of each stack in square brackets, starting at the +bottom. + +1 [1] +0 [1, 0] +1 [1, 0, 1] +- [1, -1] + +This part is trivial. What happens next, however, varies. + +One incorrect possibility: +{ [1, 0, 0], [] +} [1] + +Here, { pushes abs(-1) zeroes onto the SOSS before a new stack is pushed. Since +there was no SOSS at that time, the zero pushed doesn't appear. + +This is the behaviour of the Flaming Bovine Befunge Interpreter version +2003.0326, amended with the 2003.0722 and 2003.0726 patches. + +Another: +{ [1, 0, 0], [0] +} [1] + +It seems that here, abs(-1) zeroes are being pushed on the TOSS instead of the +SOSS. + +This is the behaviour of the RC/Funge-98 interpreter, version 1.07, as well as +of the RC/Funge-98 interpreter modified by Jesse van Herk, version 1.05. + +What should happen: +{ [1, 0, 0, 0], [] +} [1, 0] + +This is the behaviour of the Conforming Concurrent Befunge-98 Interpreter, +version 1.00. + +Let's see what the spec has to say about the subject: + + "The { 'Begin Block' instruction pops a cell it calls n, then pushes a new + stack on the top of the stack stack, transfers n elements from the SOSS to + the TOSS, then pushes the storage offset as a vector onto the SOSS..." + + "If n is negative, |n| zeroes are pushed onto the SOSS." + +In other words, { should: + + Pop the -1 from the stack. [1] + Push a new stack on the stack stack. [1], [] + Since -1 < 0, push |-1| = 1 zero onto the SOSS. [1, 0], [] + Push the storage offset onto the SOSS. [1, 0, 0, 0], [] + +"BAD: 4k #..." and "BAD: 2k ;;;5..." +.................................... + +In Funge-98, spaces and semicolons are ethereal. The "next instruction" +mentioned in the spec refers specifically to the next instruction the +interpreter would execute if the k would not be there. + +Hence, k always executes its operand at the k, but reaches past all spaces and +semicolons to find the operand. Hence 2k ;;;5 should execute the 5 twice at the +k. (See the next section for the reason why it should be executed a third time +afterward.) + +"BAD: 2k6..." +............. + +The specification does not say that the operand should be skipped over after +execution. The only special case is when the amount of times to execute is +zero. + +This means that 2k6 should indeed first push 2 sixes at the k, and then a third +when encountering the 6 itself. + +This also means that there is no way to execute an instruction only once: 1k6 +results in two sixes. (Another IP may certainly modify the 6 immediately after +the k is executed, but that's a somewhat unlikely case and not exactly a good +way to handle this limitation.) + +The spec is somewhat unclear on the entirety of k, but both of the above issues +have been confirmed with Chris Pressey. + +Old changes +----------- + + 2009-05-13 - MycoTRDS accepts P-values greater than 0 and reports + unacceptable values as UNDEF, not BAD. + 2009-04-04 - Made the u test not abort if the storage offset isn't (0,0). + - Bugfix: u outputs the correct error message if it fails with + a positive count. + 2009-03-31 - Bugfix: some w were misaligned in the TOYS test. + 2009-03-29 - Bugfix: 1y bits testing was really broken, really fixed it + now. + 2009-03-28 - Update: FILE's R really should reflect at EOF. + - Update: removed the 'G to an infinite loop' test from STRN, + it makes sense that it does indeed loop forever. + - Bugfix: it was always claimed that I/O was buffered. + - Bugfix: 1y being greater than 15 was complained about: + should have been 31. + 2008-11-15 - ) with a negative count wasn't actually tested, ( was used + both times. + 2008-10-17 - If o doesn't work, it is reported that i in binary mode will + not be tested. + 2008-09-21 - Fixed a misalignment in the fingerprint loading code. + 2008-09-16 - MycoTRDS now expects ticks to start from zero, thus the + expected value of G is one lower. + 2008-09-15 - Fixed a misalignment in the u test with a negative argument. + 2008-09-14 - Made the wraparound with non-cardinal delta test catch a + common case. + 2008-09-13 - Bugfix: test for k with negative argument was expecting + incorrect k behaviour. + - Bugfix: "GOOD: SGML spaces" was never output, who knows for + how long that's been disabled. + - Bugfix: IMAP check for non-ASCII now says it works when it + works. + - Update: IMAP check for non-ASCII is now GOOD when it works + and BAD otherwise, per the latest spec. + - Update: IMAP now checks mappings outside range 0-255. + - Update: INDV now expects the logical order, reporting BAD + otherwise. + 2008-09-12 - Reduce stacking in HRTI test. + - Corrected typo in a TOYS error message. + 2008-09-10 - Made the check for wraparound with non-cardinal delta a bit + stricter (instead of a delta of (12,0) it uses (13,2)). + 2008-09-06 - Fixed a misspelled error message in mycouser.b98 for + Befunge-93 interpreters. + - Fixed a bug in 2k6 testing that led to an infinite loop. + 2008-08-30 - Fixed the case where SCKE is included in SOCK. + 2008-08-28 - SOCK and SCKE fixed: much code still assumed that A + overwrites the original socket, and thus wrong sockets were + being given to K and P. + 2008-08-20 - Bugfix: results for the ;; concurrency test were off by one. + - Test new A and O instructions in SUBR. + 2008-08-19 - Bugfix: results for the concurrency tests 5kz and "a b" + were incorrect. + 2008-08-14 - New fingerprint: DATE. + 2008-08-13 - I had managed to get the way y should work as a pick + instruction completely wrong. Thanks to Johannes Laire for + noticing this and notifying me. + 2008-08-11 - Removed PNTR (the same as INDV), it wasn't meant to exist + any more. + 2008-08-09 - The new addition to the FILE fingerprint, D, is now tested. + - Using it, created .tmp files can now be removed from within + Mycology. + 2008-07-26 - Thanks to Arvid Norlander, Chris Pressey, and Mike Riley, + none of k is UNDEF any longer, and some tests were changed + to reflect the intended behaviour. + - Expanded the null byte test. + - Bugfix: in SOCK, the original socket should /not/ be + destroyed: flipped a GOOD and BAD. + 2008-07-19 - Now testing whether null bytes are handled correctly. + 2008-05-02 - Bugfix: mycouser.b98 had a forgotten r in place of a (. + 2008-03-30 - Bugfix: J test in SUBR was misaligned. + 2008-03-29 - Bugfix: D failing in TOYS had no error message. + - Bugfex: L and R in TOYS had incorrect error messages. + 2008-03-15 - Bugfix: time output for hours <= 10 was incorrect. + 2008-03-13 - Bugfix: a missing ; caused an incorrect error message. + 2008-03-11 - i and o are now UNDEF if unavailable. + - PERL is now tested with "5-1" instead of the palindromic + "2+2". Thanks to Alex Smith for the input. + 2008-02-02 - 1k # now considered UNDEF. + 2008-01-09 - More typos or incorrect messages. + 2007-12-02 - Corrected some typos. + 2007-09-22 - Minor bugfixes. + 2007-09-20 - Public release. + 2007-07-26 - Creation of mycoterm.b98 and mycotrds.b98. + 2007-06-17 - Creation of mycouser.b98. + 2007-01-06 - Creation of mycorand.bf. + 2006-12-31 - Creation of sanity.bf and mycology.b98. diff --git a/tests/mycology/sanity.bf b/tests/mycology/sanity.bf new file mode 100644 --- /dev/null +++ b/tests/mycology/sanity.bf @@ -0,0 +1,1 @@ +9876543210 ..... ..... #@ Intentionally invalid instruction, should reflect diff --git a/tests/refc.bf b/tests/refc.bf new file mode 100644 --- /dev/null +++ b/tests/refc.bf @@ -0,0 +1,2 @@ +12R34R56RDDD@ diff --git a/tests/roma.bf b/tests/roma.bf new file mode 100644 --- /dev/null +++ b/tests/roma.bf @@ -0,0 +1,2 @@ +CDILMVX@ diff --git a/tests/string93Mode.bf b/tests/string93Mode.bf new file mode 100644 --- /dev/null +++ b/tests/string93Mode.bf @@ -0,0 +1,1 @@ +<@"Hello world! My name is Betty."B(4"BF93" diff --git a/tests/stringMode.bf b/tests/stringMode.bf new file mode 100644 --- /dev/null +++ b/tests/stringMode.bf @@ -0,0 +1,1 @@ +<@"today is Monday!" diff --git a/tests/stringModeWrap.bf b/tests/stringModeWrap.bf new file mode 100644 --- /dev/null +++ b/tests/stringModeWrap.bf @@ -0,0 +1,6 @@ +v Upon exit, stack from top to bottom should be: + GOOD: [60,64,32] + BAD: [60,32,64,32] + +> v +@ "<