Fungi 1.0.3 → 1.0.4
raw patch · 19 files changed
+571/−56 lines, 19 files
Files
- CHANGELOG +12/−0
- Data/StackSet.hs +59/−0
- Fingerprint.hs +4/−0
- Fingerprint/BF93.hs +10/−10
- Fingerprint/BZRO.hs +7/−10
- Fingerprint/MODE.hs +6/−6
- Fingerprint/RECD.hs +135/−0
- Fingerprint/STRN.hs +168/−0
- Fungi.cabal +8/−10
- Instruction.hs +10/−8
- Ip.hs +29/−8
- Mode.hs +2/−0
- README +9/−1
- Space/Space.hs +1/−0
- Text/Help/Fingerprint.hs +6/−0
- Text/Help/Fingerprint/BZRO.hs +2/−2
- Text/Help/Fingerprint/RECD.hs +48/−0
- Text/Help/Fingerprint/STRN.hs +54/−0
- Version.hs +1/−1
+ CHANGELOG view
@@ -0,0 +1,12 @@+1.04+- Added RECD fingerprint.+- Added STRN fingerprint.+- While displaying modes for the current IP, the modes are now displayed such that more recent modes are displayed toward the left of less recent modes.+- Fixed an error in BZRO mode documentation. The errornous sentence was: "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." It is now corrected to say: "As an example, if Hover mode is enabled after and while Bizarro mode is enabled, (<) will subtract 1 from the IP's first delta coordinate."++1.0.3+- Added documentation for fingerprints via --finger-doc option.+- Fixed ORTH 'Z' instruction bug.+- Added BF93 fingerprint.+- Added BZRO fingerprint.+- Added NOP fingerprint.
+ Data/StackSet.hs view
@@ -0,0 +1,59 @@+module Data.StackSet (+ StackSet+ , empty+ , toList+ , insert+ , delete+ , member+ ) where++import Data.Labeled+import Data.List (sortBy)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Ord (comparing)++-----------------------------------------------------------++newtype Tagged l a = T { untag :: Labeled l a }++instance (Eq a) => Eq (Tagged l a) where+ T l1 == T l2 = unlabel l1 == unlabel l2++instance (Ord a) => Ord (Tagged l a) where+ compare (T l1) (T l2) = comparing unlabel l1 l2++type Tag = Int++data StackSet a = S !Tag (Set (Tagged Tag a))++empty :: StackSet a+empty = S maxBound Set.empty++toList :: StackSet a -> [a]+toList (S _ set) = map (unlabel . untag) $ sortBy (comparing $ getLabel . untag) $ Set.toList set++insert :: (Ord a) => a -> StackSet a -> StackSet a+insert x stackSet@(S n _) = if n > minBound+ then insert' x stackSet'+ else insert' x $ retag stackSet'+ where+ stackSet' = delete x stackSet++insert' :: (Ord a) => a -> StackSet a -> StackSet a+insert' x (S n set) = if n > minBound+ then S (n - 1) $ Set.insert (T $ label n x) set+ else error "StackSet.insert: Too many elements in stackset!"++retag :: (Ord a) => StackSet a -> StackSet a+retag = foldr insert' empty . toList++dummyTag :: a -> Tagged Tag a+dummyTag x = T $ label undefined x++delete :: (Ord a) => a -> StackSet a -> StackSet a+delete x (S n set) = S n $ Set.delete (dummyTag x) set++member :: (Ord a) => a -> StackSet a -> Bool+member x (S _ set) = Set.member (dummyTag x) set+
Fingerprint.hs view
@@ -24,8 +24,10 @@ import qualified Fingerprint.NOP as NOP import qualified Fingerprint.NULL as NULL import qualified Fingerprint.ORTH as ORTH+import qualified Fingerprint.RECD as RECD import qualified Fingerprint.REFC as REFC import qualified Fingerprint.ROMA as ROMA+import qualified Fingerprint.STRN as STRN ----------------------------------------------------------- @@ -48,8 +50,10 @@ , (NOP.name, NOP.semantics ) , (NULL.name, NULL.semantics) , (ORTH.name, ORTH.semantics)+ , (RECD.name, RECD.semantics) , (REFC.name, REFC.semantics) , (ROMA.name, ROMA.semantics)+ , (STRN.name, STRN.semantics) ] where insert k v m = if Map.member k m
Fingerprint/BF93.hs view
@@ -27,24 +27,24 @@ ('B', bInstr) ] -string93modeInstructions :: (I i) => (i -> Maybe (Instruction i ()), Map i (Maybe (Instruction i ())))-string93modeInstructions = (,) (Just . pushInstr) $ buildInstructions [- ('"', Just string93modeInstr)+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+string93ModeInstr :: (I i) => Instruction i ()+string93ModeInstr = do modify $ withIp $ toggleMode mode- modify $ withSemantics $ Semantics.toggleOverlay mode string93modeInstructions+ 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)+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)@@ -76,7 +76,7 @@ bInstr :: (I i) => Instruction i () bInstr = do modify $ withIp $ toggleMode mode- modify $ withSemantics $ Semantics.toggleOverlay mode befunge93modeInstructions+ modify $ withSemantics $ Semantics.toggleOverlay mode befunge93ModeInstructions where mode = Mode.Befunge93
Fingerprint/BZRO.hs view
@@ -3,12 +3,11 @@ , semantics ) where -import Prelude hiding (lookup)- import Control.Monad.State.Strict import Data.Char (chr, ord) import Data.Map (Map)+import Data.Maybe (fromMaybe) import Data.Tuple.Map import Space.Cell@@ -17,7 +16,7 @@ import Instruction import Ip import Mode-import Semantics+import qualified Semantics ----------------------------------------------------------- @@ -31,15 +30,13 @@ 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+ sem <- gets $ Semantics.removeOverlay Mode.Bizarro . getSemantics . currentIp+ fromMaybe (unknownInstr i) $ Semantics.lookup i sem where i = ordCell $ charToCell c -bizarromodeInstructions :: (I i) => (i -> Maybe (Instruction i ()), Map i (Maybe (Instruction i ())))-bizarromodeInstructions = (,) f $ buildInstructions $ map (map2 $ Just . runInstructionInstr) [+bizarroModeInstructions :: (I i) => (i -> Maybe (Instruction i ()), Map i (Maybe (Instruction i ())))+bizarroModeInstructions = (,) f $ buildInstructions $ map (map2 $ Just . runInstructionInstr) [ ('>', '<') , ('<', '>') , ('^', 'v')@@ -83,7 +80,7 @@ bInstr :: (I i) => Instruction i () bInstr = do modify $ withIp $ toggleMode mode- modify $ withSemantics $ Semantics.toggleOverlay mode bizarromodeInstructions+ modify $ withSemantics $ Semantics.toggleOverlay mode bizarroModeInstructions where mode = Mode.Bizarro
Fingerprint/MODE.hs view
@@ -58,8 +58,8 @@ 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 [+hoverModeInstructions :: (I i) => (i -> Maybe (Instruction i ()), Map i (Maybe (Instruction i ())))+hoverModeInstructions = (,) (const Nothing) $ buildInstructions [ ('>', Just hoverGoEastInstr) , ('<', Just hoverGoWestInstr) , ('^', Just hoverGoNorthInstr)@@ -75,8 +75,8 @@ 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 [+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)@@ -90,7 +90,7 @@ hInstr :: (I i) => Instruction i () hInstr = do modify $ withIp $ toggleMode mode- modify $ withSemantics $ Semantics.toggleOverlay mode hovermodeInstructions+ modify $ withSemantics $ Semantics.toggleOverlay mode hoverModeInstructions where mode = Mode.Hover @@ -103,7 +103,7 @@ sInstr :: (I i) => Instruction i () sInstr = do modify $ withIp $ toggleMode mode- modify $ withSemantics $ Semantics.toggleOverlay mode switchmodeInstructions+ modify $ withSemantics $ Semantics.toggleOverlay mode switchModeInstructions where mode = Mode.Switch
+ Fingerprint/RECD.hs view
@@ -0,0 +1,135 @@+module Fingerprint.RECD (+ name+ , semantics+ ) where++import Control.Monad.State.Strict++import Data.Foldable (foldl', toList)+import Data.List (genericTake, genericDrop, intersperse)+import Data.Map (Map)+import Data.Maybe (fromMaybe)+import Data.Sequence (Seq)++import Env+import Instruction+import Ip+import Mode+import Semantics++-----------------------------------------------------------++name :: String+name = "RECD"++semantics :: (I i) => [(Char, Instruction i ())]+semantics = [+ ('C', cInstr)+ , ('L', lInstr)+ , ('N', nInstr)+ , ('R', rInstr)+ , ('P', pInstr)+ , ('Q', qInstr)+ ]++recordingMode :: Mode+recordingMode = Mode.Record++learnInstructions :: (I i) => (i -> Maybe (Instruction i ()), Map i (Maybe (Instruction i ())))+learnInstructions = (,) (Just . learnInstr_) $ buildInstructions [+ ('L', Just lInstr)+ ]++recordInstructions :: (I i) => (i -> Maybe (Instruction i ()), Map i (Maybe (Instruction i ())))+recordInstructions = (,) (Just . recordInstr) $ buildInstructions [+ ('R', Just rInstr)+ ]++learnInstr_ :: (I i) => i -> Instruction i ()+learnInstr_ i = learnInstr i >> return ()++learnInstr :: (I i) => i -> Instruction i (Instruction i ())+learnInstr i = do+ sem <- gets $ Semantics.removeOverlay recordingMode . getSemantics . currentIp+ let instr = fromMaybe (unknownInstr i) $ Semantics.lookup i sem+ modify $ withIp $ record instr+ recordLen <- gets $ getRecordLength . currentIp+ modify $ withIp $ setRecordLength $! recordLen + 1+ return instr++recordInstr :: (I i) => i -> Instruction i ()+recordInstr = join . learnInstr++cInstr :: (I i) => Instruction i ()+cInstr = do+ recording <- gets $ testMode Mode.Record . currentIp+ learning <- gets $ testMode Mode.Learn . currentIp+ if recording || learning+ then reverseInstr+ else modify $ withIp clearRecordings++seqLength :: (Integral i) => Seq a -> i+seqLength = foldl' (\n _ -> n + 1) 0++nInstr :: (I i) => Instruction i ()+nInstr = gets (seqLength . getRecordings . currentIp) >>= pushInstr++lInstr :: (I i) => Instruction i ()+lInstr = do+ recording <- gets $ testMode Mode.Record . currentIp+ if recording+ then reverseInstr+ else do+ learning <- gets $ testMode Mode.Learn . currentIp+ when learning $ do+ recordLen <- gets $ getRecordLength . currentIp+ modify $ withIp $ setRecordLength 0+ pushInstr recordLen+ modify $ withIp $ toggleMode Mode.Learn+ modify $ withSemantics $ Semantics.toggleOverlay recordingMode learnInstructions++rInstr :: (I i) => Instruction i ()+rInstr = do+ learning <- gets $ testMode Mode.Learn . currentIp+ if learning+ then reverseInstr+ else do+ recording <- gets $ testMode Mode.Record . currentIp+ when recording $ do+ recordLen <- gets $ getRecordLength . currentIp+ modify $ withIp $ setRecordLength 0+ pushInstr recordLen+ modify $ withIp $ toggleMode Mode.Record+ modify $ withSemantics $ Semantics.toggleOverlay recordingMode recordInstructions++getRecordingsInstr :: (I i) => Instruction i [Instruction i ()]+getRecordingsInstr = do+ idx <- popInstr+ n <- popInstr+ let takeN = if n >= 0+ then genericTake n+ else id+ gets (takeN . genericDrop idx . toList . getRecordings . currentIp) ++pInstr :: (I i) => Instruction i ()+pInstr = do+ recording <- gets $ testMode Mode.Record . currentIp+ learning <- gets $ testMode Mode.Learn . currentIp+ if recording || learning+ then reverseInstr+ else do+ modify $ withIp $ addMode Mode.Learn . addMode Mode.Record+ getRecordingsInstr >>= sequence_ . intersperse trampolineInstr+ modify $ withIp $ removeMode Mode.Learn . removeMode Mode.Record++qInstr :: (I i) => Instruction i ()+qInstr = do+ recording <- gets $ testMode Mode.Record . currentIp+ learning <- gets $ testMode Mode.Learn . currentIp+ if recording || learning+ then reverseInstr+ else do+ modify $ withIp $ addMode Mode.Learn . addMode Mode.Record+ getRecordingsInstr >>= sequence_+ modify $ withIp $ removeMode Mode.Learn . removeMode Mode.Record+
+ Fingerprint/STRN.hs view
@@ -0,0 +1,168 @@+module Fingerprint.STRN (+ name+ , semantics+ ) where++import Control.Monad.State.Strict++import Data.Char (isDigit, isSpace)+import Data.IntegralLike+import Data.List (tails, isPrefixOf, genericTake, genericDrop, genericLength, foldl')+import Data.Maybe (fromMaybe, listToMaybe)+import Data.MaybeBounded+import Data.Vector++import Space.Cell+import Space.Space++import System.IO (hFlush, stdout)++import Env+import Instruction+import Ip++-----------------------------------------------------------++name :: String+name = "STRN"++semantics :: (I i) => [(Char, Instruction i ())]+semantics = [+ ('A', aInstr)+ , ('C', cInstr)+ , ('D', dInstr)+ , ('F', fInstr)+ , ('G', gInstr)+ , ('I', iInstr)+ , ('L', lInstr)+ , ('M', mInstr)+ , ('N', nInstr)+ , ('P', pInstr)+ , ('R', rInstr)+ , ('S', sInstr)+ , ('V', vInstr)+ ]++pushStringInstr :: (I i) => [i] -> Instruction i ()+pushStringInstr str = do+ pushInstr 0+ pushVectorInstr $ mkVector $ reverse str++aInstr :: (I i) => Instruction i ()+aInstr = do+ s1 <- popStringInstr'+ s2 <- popStringInstr'+ pushStringInstr $ s1 ++ s2++cInstr :: (I i) => Instruction i ()+cInstr = do+ s1 <- popStringInstr'+ s2 <- popStringInstr'+ pushInstr $ case compare s1 s2 of+ GT -> 1+ LT -> -1+ EQ -> 0++dInstr :: (I i) => Instruction i ()+dInstr = do+ s <- liftM (map $ fromMaybe '?') popStringInstr+ liftIO $ putStr s++search :: (Eq a) => [a] -> [a] -> [a]+search needle = fromMaybe [] . listToMaybe . filter (needle `isPrefixOf`) . tails++fInstr :: (I i) => Instruction i ()+fInstr = do+ s1 <- popStringInstr'+ s2 <- popStringInstr'+ pushStringInstr $ search s2 s1++gInstr :: (I i) => Instruction i ()+gInstr = do+ env <- get+ let dim = getDim env+ space = getSpace env+ east = takeV dim $ 1 `cons` 0+ so = getStorageOffset $ currentIp env+ (minC, _, space') = minMaxCoords space+ minX = head $ unVector minC+ wrappingAdd v w = let z = v + w+ in if inBounds space' z+ then z+ else minX `cons` (dropV 1 z)+ pos <- popDimVectorInstr+ let poses = iterate (wrappingAdd east) $ pos + so+ cells = map (cellAt space) poses+ vals = map ordCell cells+ str = takeWhile (/= 0) vals+ modify $ withSpace $ const space'+ pushStringInstr str++iInstr :: (I i) => Instruction i ()+iInstr = do+ str <- liftIO $ do+ hFlush stdout+ getLine+ pushStringInstr $ map asIntegral str++lInstr :: (I i) => Instruction i ()+lInstr = do+ n <- popInstr+ str <- popStringInstr'+ pushStringInstr $ genericTake n str++mInstr :: (I i) => Instruction i ()+mInstr = do+ n <- popInstr+ p <- popInstr+ str <- popStringInstr'+ pushStringInstr $ genericTake n $ genericDrop p str++nInstr :: (I i) => Instruction i ()+nInstr = do+ str <- popStringInstr'+ pushStringInstr str -- needs to be done like this because of Hover mode+ pushInstr $ genericLength str++pInstr :: (I i) => Instruction i ()+pInstr = do+ env <- get+ let dim = getDim env+ space = getSpace env+ east = takeV dim $ 1 `cons` 0+ so = getStorageOffset $ currentIp env+ pos <- popDimVectorInstr+ str <- liftM (++ [0]) popStringInstr'+ let cells = map chrCell str+ poses = iterate (east +) $ pos + so+ space' = foldl' (\s -> uncurry $ putCell s) space $ zip cells poses+ modify $ withSpace $ const space'++rInstr :: (I i) => Instruction i ()+rInstr = do+ n <- popInstr+ str <- popStringInstr'+ pushStringInstr $ reverse $ genericTake n $ reverse str++sInstr :: (I i) => Instruction i ()+sInstr = popInstr >>= pushStringInstr . map asIntegral . show++atoi :: (MaybeBounded i, Integral i) => String -> i+atoi str = n''+ where+ n'' = fromInteger $ maybe n' (min n' . fromIntegral) $ maybeMaxBound `asTypeOf` Just n''+ n' = maybe n (max n . fromIntegral) $ maybeMinBound `asTypeOf` Just n''+ n = case dropWhile isSpace str of+ "" -> 0+ '+':cs -> atoi' cs+ '-':cs -> negate $ atoi' cs+ cs -> atoi' cs++atoi' :: String -> Integer+atoi' = foldl' (\n c -> 10 * n + read [c]) 0 . takeWhile isDigit++vInstr :: (I i) => Instruction i ()+vInstr = do+ str <- liftM (map $ fromMaybe '?') popStringInstr+ pushInstr $ atoi str +
Fungi.cabal view
@@ -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.3+Version: 1.0.4 -- A short (one-line) description of the package. Synopsis: An interpreter for Funge-98 programming languages, including Befunge.@@ -32,13 +32,10 @@ Build-type: Simple --- Extra files to be distributed with the package, such as examples or--- a README.--- Extra-source-files: - Cabal-version: >= 1.6 Extra-source-files:+ CHANGELOG README Tester.hs runTests.bash@@ -65,6 +62,7 @@ , containers >= 0.3 , directory >= 1.0 , filepath >= 1.1+ , haskell98 >= 1.0 , ListZipper >= 1.2 , mtl >= 1.1 , mwc-random >= 0.8@@ -72,7 +70,6 @@ , process >= 1.0 , random >= 1.0 , tuple >= 0.2- , haskell98 >= 1.0 -- Modules not exported by this package. Other-modules:@@ -85,6 +82,7 @@ Data.LogicalBits Data.MaybeBounded Data.Stack+ Data.StackSet Data.Tuple.Map Data.Vector Debug.Debug@@ -103,8 +101,10 @@ Fingerprint.NOP Fingerprint.NULL Fingerprint.ORTH+ Fingerprint.RECD Fingerprint.REFC Fingerprint.ROMA+ Fingerprint.STRN Fungi Instruction Interpreter@@ -132,8 +132,10 @@ Text.Help.Fingerprint.NOP Text.Help.Fingerprint.NULL Text.Help.Fingerprint.ORTH+ Text.Help.Fingerprint.RECD Text.Help.Fingerprint.REFC Text.Help.Fingerprint.ROMA+ Text.Help.Fingerprint.STRN Text.PrettyShow Text.PrintOption UnknownInstruction@@ -142,10 +144,6 @@ ---- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.--- Build-tools: -
Instruction.hs view
@@ -5,6 +5,7 @@ , baseInstructions , lookupInstruction , runCurrentInstruction+ , currentInstruction , guardDim , guardZero@@ -21,6 +22,7 @@ , popVectorInstr , popDimVectorInstr , popStringInstr+ , popStringInstr' , tryLiftIO , nopInstr@@ -56,7 +58,7 @@ , inputCharacterInstr , outputDecimalInstr , inputDecimalInstr- , stringmodeInstr+ , stringModeInstr , fetchCharacterInstr , unknownInstr , spaceInstr@@ -149,7 +151,7 @@ baseInstructions = buildInstructions $ [ (' ', spaceInstr) , ('!', logicalNotInstr)- , ('"', stringmodeInstr)+ , ('"', stringModeInstr) , ('#', trampolineInstr) , ('$', popInstr_) , ('%', remainderInstr)@@ -505,9 +507,9 @@ -- Strings ----------------------------------------------------------- -stringmodeInstructions :: (I i) => (i -> Maybe (Instruction i ()), Map i (Maybe (Instruction i ())))-stringmodeInstructions = (,) (Just . pushInstr) $ buildInstructions [- ('"', Just stringmodeInstr)+stringModeInstructions :: (I i) => (i -> Maybe (Instruction i ()), Map i (Maybe (Instruction i ())))+stringModeInstructions = (,) (Just . pushInstr) $ buildInstructions [+ ('"', Just stringModeInstr) , (' ', Just sgmlSpaceInstr) ] where@@ -517,10 +519,10 @@ whileM_ (atInstr ' ') trampolineInstr moveBackByDeltaInstr -stringmodeInstr :: (I i) => Instruction i ()-stringmodeInstr = do+stringModeInstr :: (I i) => Instruction i ()+stringModeInstr = do modify $ withIp $ toggleMode mode- modify $ withSemantics $ Semantics.toggleOverlay mode stringmodeInstructions+ modify $ withSemantics $ Semantics.toggleOverlay mode stringModeInstructions where mode = Mode.String
Ip.hs view
@@ -17,6 +17,12 @@ , removeMode , toggleMode + , record+ , clearRecordings+ , getRecordings+ , getRecordLength+ , setRecordLength+ , killIp , reverseIp , setPos@@ -31,8 +37,10 @@ import Data.Deque import Data.I import Data.Map (Map)-import Data.Set (Set)-import qualified Data.Set as Set+import Data.StackSet (StackSet)+import qualified Data.StackSet as StackSet+import Data.Sequence+import qualified Data.Sequence as Seq import Data.Stack import Data.Vector @@ -55,8 +63,10 @@ , isAlive :: Bool , getStorageOffset :: !(Vector i) , getSemantics :: Semantics env i- , modes :: Set Mode+ , modes :: StackSet Mode , hrtiMark :: Maybe ClockTime+ , getRecordings :: Seq (Instruction env i ())+ , getRecordLength :: i } instance (PrettyShow i) => PrettyShow (Ip env i) where@@ -69,7 +79,7 @@ , " " , "delta=" ++ pshow (getDelta ip) , " "- , "modes=" ++ pshow (Set.toList $ modes ip)+ , "modes=" ++ pshow (StackSet.toList $ modes ip) , ")" ] @@ -82,18 +92,20 @@ , isAlive = True , getStorageOffset = takeV dim 0 , getSemantics = mkSemantics baseSemantics- , modes = Set.empty+ , modes = StackSet.empty , hrtiMark = Nothing+ , getRecordings = Seq.empty+ , getRecordLength = 0 } testMode :: Mode -> Ip env i -> Bool-testMode mode = Set.member mode . modes+testMode mode = StackSet.member mode . modes addMode :: Mode -> Ip env i -> Ip env i-addMode mode ip = ip { modes = Set.insert mode $ modes ip }+addMode mode ip = ip { modes = StackSet.insert mode $ modes ip } removeMode :: Mode -> Ip env i -> Ip env i-removeMode mode ip = ip { modes = Set.delete mode $ modes ip }+removeMode mode ip = ip { modes = StackSet.delete mode $ modes ip } toggleMode :: Mode -> Ip env i -> Ip env i toggleMode mode ip = if testMode mode ip@@ -117,4 +129,13 @@ setStorageOffset :: Vector i -> Ip env i -> Ip env i setStorageOffset v ip = ip { getStorageOffset = v }++setRecordLength :: i -> Ip env i -> Ip env i+setRecordLength n ip = ip { getRecordLength = n }++clearRecordings :: Ip env i -> Ip env i+clearRecordings ip = ip { getRecordings = Seq.empty }++record :: Instruction env i () -> Ip env i -> Ip env i+record instr ip = ip { getRecordings = getRecordings ip |> instr }
Mode.hs view
@@ -11,6 +11,8 @@ | Bizarro | Hover | Invert+ | Learn+ | Record | String | String93 | Switch
README view
@@ -1,3 +1,11 @@-For information on how to use Fungi, run it with the --help command line argument:+For information on how to use Fungi, run the program with the --help command line argument.+Note that the --help option will list all implemented fingerprints. fungi --help++--------------------------------------------------------------------------------++For information on how to use a fingerprint, run the program with the --finger-doc command line argument.++fungi --finger-doc NAME+
Space/Space.hs view
@@ -6,6 +6,7 @@ , travelBy , minMaxCoords , putSpaceAt+ , inBounds ) where import Data.ByteString.Char8 (ByteString)
Text/Help/Fingerprint.hs view
@@ -17,8 +17,10 @@ import qualified Fingerprint.NOP as NOP import qualified Fingerprint.NULL as NULL import qualified Fingerprint.ORTH as ORTH+import qualified Fingerprint.RECD as RECD import qualified Fingerprint.REFC as REFC import qualified Fingerprint.ROMA as ROMA+import qualified Fingerprint.STRN as STRN import qualified Text.Help.Fingerprint.BASE as H_BASE import qualified Text.Help.Fingerprint.BF93 as H_BF93@@ -32,8 +34,10 @@ import qualified Text.Help.Fingerprint.NOP as H_NOP import qualified Text.Help.Fingerprint.NULL as H_NULL import qualified Text.Help.Fingerprint.ORTH as H_ORTH+import qualified Text.Help.Fingerprint.RECD as H_RECD import qualified Text.Help.Fingerprint.REFC as H_REFC import qualified Text.Help.Fingerprint.ROMA as H_ROMA+import qualified Text.Help.Fingerprint.STRN as H_STRN ----------------------------------------------------------- @@ -62,7 +66,9 @@ , (NOP.name , H_NOP.help ) , (NULL.name, H_NULL.help) , (ORTH.name, H_ORTH.help)+ , (RECD.name, H_RECD.help) , (REFC.name, H_REFC.help) , (ROMA.name, H_ROMA.help)+ , (STRN.name, H_STRN.help) ]
Text/Help/Fingerprint/BZRO.hs view
@@ -67,8 +67,8 @@ ++ " 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"+ ++ " As with all modes, the most recent mode has priority. As an example, if Hover mode"+ ++ " is enabled after and while Bizarro mode is enabled, (<) will subtract 1 from the IP's first delta" ++ " coordinate. To alleviate any confusion about String mode, if String mode is enabled during Bizarro" ++ " mode, a (') instruction will push 39 onto the stack, and (\") will disable String mode despite the" ++ " fact that (') turns on String mode when Bizarro mode is on."
+ Text/Help/Fingerprint/RECD.hs view
@@ -0,0 +1,48 @@+module Text.Help.Fingerprint.RECD (+ help+ ) where++import Text.PrintOption++-----------------------------------------------------------++p :: Char -> String -> IO ()+p c = printOption ' ' $ " " ++ [c] ++ " --"++maxWidth :: Int+maxWidth = 80++line :: IO ()+line = putStrLn $ replicate maxWidth '-'++help :: IO ()+help = do+ p 'C' "Clear all recordings from the current IP."+ p 'N' "Push the length of the current IP's recordings."+ p 'L' $ "Toggle Learn mode. If Learn mode was on and turns off, the number of additional recorded instructions"+ ++ " is pushed onto the stack."+ p 'R' $ "Toggle Record mode. If Record mode was on and turns off, the number of additional recorded instructions"+ ++ " is pushed onto the stack."+ p 'Q' $ "Pop P. Pop N. Let L = the length of the current IP's recordings. If N < 0 or P > L, do nothing."+ ++ " Otherwise select the IP's first min(N,L-P) recorded instructions after dropping max(P,0) of them and"+ ++ " execute them by the current IP. The IP does not automatically advance between"+ ++ " any of the executed instructions. The (Q) instruction takes a single tick."+ p 'P' $ "Pop P. Pop N. Let L = the length of the current IP's recordings. If N < 0 or P > L, do nothing."+ ++ " Otherwise select the IP's first min(N,L-P) recorded instructions after dropping max(P,0) of them and"+ ++ " execute them by the current IP. In between each executed instruction, the IP advances automatically."+ ++ " The phrase 'In between' should be taken literally, for the IP does not automatically advance after the last"+ ++ " executed instruction. That being said, the IP naturally advances after the (P) instruction completes."+ ++ " The (P) instruction takes a single tick."+ line+ putStrLn "\n ** LEARN MODE **\n"+ putStrLn $ fit maxWidth $ "While in Learn mode, all the RECD instructions except (N) and (L) act as if they reflect."+ ++ " Instead of executing the current instruction, the IP records the instruction. Circumstantial data, such"+ ++ " as the IP's state (stack, position, modes, delta, etc.), are not recorded. These recordings are appended"+ ++ " to previous recordings, if any. Learn mode and Record mode share recordings."+ line+ putStrLn "\n ** Record MODE **\n"+ putStrLn $ fit maxWidth $ "While in Record mode, all the RECD instructions except (N) and (R) act as if they reflect."+ ++ " In addition to executing the current instruction, the IP records the instruction. Circumstantial data, such"+ ++ " as the IP's state (stack, position, modes, delta, etc.), are not recorded. These recordings are appended"+ ++ " to previous recordings, if any. Learn mode and Record mode share recordings."+
+ Text/Help/Fingerprint/STRN.hs view
@@ -0,0 +1,54 @@+module Text.Help.Fingerprint.STRN (+ help+ ) where++import Text.PrintOption++-----------------------------------------------------------++p :: Char -> String -> IO ()+p c = printOption ' ' $ " " ++ [c] ++ " --"++maxWidth :: Int+maxWidth = 80++line :: IO ()+line = putStrLn $ replicate maxWidth '-'++help :: IO ()+help = do+ putStrLn $ fit maxWidth $ "All strings described by this fingerprint (STRN) are 0 terminated strings."+ ++ " By default, let variables of the form S or S# be strings. Strings are stored on the stack such that"+ ++ " the terminating 0 is popped last. Let |S| be defined to the the length of S"+ ++ " excluding the terminating 0. Note that strings are simply sequences of integer values."+ line+ p 'A' "Pop S1. Pop S2. Push the string formed by appending S2 to S1."+ p 'C' $ "Pop S1. Pop S2. Push 1 if S1 > S2. Push -1 if S1 < S2. Otherwise push 0. These comparisons are"+ ++ " done lexicographically."+ p 'D' $ "Output the string as Unicode characters to the standard output. Any numbers that cannot be converted"+ ++ " to Unicode characters are displayed as question marks ('?')."+ p 'F' $ "Pop S1. Pop S2. While S2 is not a prefix of S1 and S1 is not the empty string, drop a value from S1."+ ++ " Push the resulting string S1."+ p 'G' $ "Pop a vector V. Read a string from funge space beginning at V, heading east, until a 0 is encountered."+ ++ " The read string may wrap across the edge of space exactly as an IP would normally wrap with a delta of east."+ ++ " Push the read string."+ p 'I' $ "Read a line from the standard input. Push the resulting string onto the stack. The newline is not part of"+ ++ " the string."+ p 'L' $ "Pop N. Pop S. If N < 0, push the empty string. If N > |S|, push S. Otherwise push the string composed of"+ ++ " the first N values of S."+ p 'M' $ "Pop N. Pop P. Pop S. If N < 0 or P > |S|, push the empty string. If P < 0, let Z = S. Otherwise let Z be"+ ++ " the string S but with the first P characters removed. If N > |Z|, push Z. Otherwise push the string"+ ++ " consisting of the first N characters of Z."+ p 'N' "Pop S. Push S. Push |S|."+ p 'P' $ "Pop S. Pop a vector V. Store the string S in funge space at beginning at position V, heading east."+ ++ " Note that the terminating 0 is stored in funge space."+ p 'R' $ "Pop N. Pop S. If N < 0, push the empty string. If N > |S|, push S. Otherwise push the string"+ ++ " composed of the last N values of S."+ p 'S' $ "Pop N. Push the ASCII string representation of N. Note that if N < 0, a '-' (45) will be pushed last."+ ++ " If N >= 0, a '+' (43) is NOT pushed at all."+ p 'V' $ "Pop S. Let Z be the string S but with leading (Latin-1) whitespace stripped. Read an integer from Z,"+ ++ " optionally signed with a '+' (43) or a '-' (45). The reading is done until a value outside of '0'-'9'"+ ++ " (48-57) is encountered. Let N be the resulting integer or 0 if nothing can be read. If the cell size"+ ++ " is bounded, N will be appropriately constrained by the bounds. (For example, if the S = \"2147483648\","+ ++ " N will be 2147483647, not -2147483648 if the cell size is 32 bits.) Push N."+
Version.hs view
@@ -9,5 +9,5 @@ handprint = 378447798 version :: String-version = "1.0.3"+version = "1.0.4"