ACME (empty) → 0.0.0.0

raw patch · 11 files changed

+375/−0 lines, 11 filesdep +basedep +list-extrasdep +mtlsetup-changed

Dependencies added: base, list-extras, mtl, random, random-shuffle, void

Files

• ACME.cabal +21/−0
• Acme/Cipher.hs +122/−0
• Acme/Money.hs +33/−0
• Acme/Peirce.hs +47/−0
• Acme/Perhaps.hs +13/−0
• Acme/Pirates.hs +55/−0
• Acme/Smash.hs +12/−0
• Acme/Trivial.hs +10/−0
• Acme/Unit.hs +30/−0
• LICENSE +30/−0
• Setup.hs +2/−0

@@ -0,0 +1,21 @@+-- Initial ACME.cabal generated by cabal init.  For further documentation, 
+-- see http://haskell.org/cabal/users-guide/
+
+name:                ACME
+version:             0.0.0.0
+synopsis:            Essential features
+-- description:         
+homepage:            alkalisoftware.net
+license:             BSD3
+license-file:        LICENSE
+author:              James Candy
+maintainer:          info@alkalisoftware.net
+-- copyright:           
+category:            Acme
+build-type:          Simple
+cabal-version:       >=1.8
+
+library
+  exposed-modules:     Acme.Cipher, Acme.Money, Acme.Peirce, Acme.Perhaps, Acme.Pirates, Acme.Smash, Acme.Trivial, Acme.Unit
+  -- other-modules:       
+  build-depends:       base <5, list-extras, random-shuffle, void, random, mtl

@@ -0,0 +1,122 @@+-- | Various ciphers.
+module Acme.Cipher (Cipher, encode, decode, playfair, substitution, addLetters, subtractLetters, viginere, caesar, Plugboard(..), Reflector(..), RotorMapping(..), enigma) where
+
+import Data.List
+import Data.Maybe
+import Data.Char
+import System.Random
+import Control.Monad.ST
+import Data.STRef
+import Control.Monad
+
+import System.Random.Shuffle
+
+-- These only work with ALLCAPSNOSPACESNOPUNCTUATION.
+
+data Cipher key = Cipher (key -> String -> String) (key -> String -> String)
+
+encode ~(Cipher f _) = f
+
+decode ~(Cipher _ f) = f
+
+-- | The Playfair cipher
+playfair = Cipher start start where
+	start k = fn (take 25 (nub (map (\ch -> if ch == 'J' then 'I' else ch) k)) ++ (['A'..'Z'] \\ ('J' : k)))
+	fn k (c1 : c2 : s) = (k !! (5 * n + y)) : (k !! (5 * x + m)) : fn k s
+		where
+			(n, m) = fromJust (findIndex (==c1) k) `divMod` 5
+			(x, y) = fromJust (findIndex (==c2) k) `divMod` 5
+	fn _ s = s
+
+swap (x, y) = (y, x)
+
+-- | The letter substitution cipher
+substitution = Cipher (\k s -> map (\ch -> fromJust $ lookup ch k) s) (\k s -> map (\ch -> fromJust $ lookup ch (map swap k)) s)
+
+letter x = ord x - ord 'A' + 1
+
+letter2 x = chr (x + ord 'A' - 1)
+
+addLetters x y = if letter2 (letter x + letter y) > 'Z' then letter2 $ letter x + letter y - 26 else letter2 $ letter x + letter y
+
+subtractLetters x y = if letter2 (letter x - letter y) < 'A' then letter2 $ letter x - letter y + 26 else letter2 $ letter x - letter y
+
+-- | The Viginere cipher (acts like one-time pad if the key is as long as the plaintext)
+viginere = Cipher (\k s -> zipWith addLetters s (cycle k)) (\k s -> zipWith subtractLetters s (cycle k))
+
+-- | The Caesar cipher
+caesar = Cipher (\k s -> map (`addLetters` k) s) (\k s -> map (`subtractLetters` k) s)
+
+-- | For good measure, the German Enigma
+data Rotor s = Rotor { mapping :: [(Char, Char)], position :: STRef s Char, nextRotor :: Maybe (Rotor s) }
+
+advance rotor = do
+	pos <- readSTRef (position rotor)
+	let plus1 = addLetters pos 'A'
+	writeSTRef (position rotor) plus1
+	when (plus1 == 'A') $ maybe (return ()) advance (nextRotor rotor)
+
+newRotor (RotorMapping mapping) init next = do
+	pos <- newSTRef init
+	return (Rotor mapping pos next)
+
+newRotors (map1,map2,map3) (init1,init2,init3) = do
+	rot1 <- newRotor map1 init1 Nothing
+	rot2 <- newRotor map2 init2 (Just rot1)
+	rot3 <- newRotor map3 init3 (Just rot2)
+	return (rot1, rot2, rot3)
+
+look ls x = fromJust (lookup x ls)
+
+rotorFunction rotor = do
+	pos <- readSTRef (position rotor)
+	return (look (mapping rotor) . (`subtractLetters` pos))
+
+reverseRotorFunction rotor = do
+	pos <- readSTRef (position rotor)
+	return ((`addLetters` pos) . look (map swap (mapping rotor)))
+
+randomLetter stdgen = randomR ('A','Z') stdgen
+
+newtype Plugboard = Plugboard [(Char, Char)]
+
+newtype Reflector = Reflector [(Char, Char)]
+
+newtype RotorMapping = RotorMapping [(Char, Char)]
+
+encodeEnigma (Plugboard plugboard, Reflector reflector0, mappings) (init1,init2,init3) text = do
+	let reflector = reflector0 ++ map swap reflector0
+	-- Create the rotors
+	(rotor1,rotor2,rotor3) <- newRotors mappings (init1,init2,init3)
+	-- Translate the plaintext
+	mapM (\letter -> do
+			f1 <- rotorFunction rotor1
+			f2 <- rotorFunction rotor2
+			f3 <- rotorFunction rotor3
+			f4 <- reverseRotorFunction rotor1
+			f5 <- reverseRotorFunction rotor2
+			f6 <- reverseRotorFunction rotor3
+			advance rotor3
+			return $ look (map swap plugboard) $ f6 $ f5 $ f4 $ look reflector $ f1 $ f2 $ f3 $ look plugboard letter)
+		text
+
+enigma stdgen = Cipher (\key plaintext -> runST $ do
+	-- Choose an initial rotor position
+	(init1, stdgen) <- return (randomLetter stdgen)
+	(init2, stdgen) <- return (randomLetter stdgen)
+	(init3, _) <- return (randomLetter stdgen)
+	-- Do the cipher
+	cipher <- encodeEnigma key (init1,init2,init3) plaintext
+	-- Add the initial rotor position
+	return (init1 : init2 : init3 : cipher))
+	(\key (init1 : init2 : init3 : cipher) -> runST $ encodeEnigma key (init1,init2,init3) cipher)
+
+rot13 = map (\x -> (x, addLetters x 'M')) ['A'..'N']
+
+test = do
+	ls <- shuffleM ['A'..'Z']
+	let k = zip ['A'..] ls
+	let key = (Plugboard k, Reflector rot13, (RotorMapping k, RotorMapping k, RotorMapping k))
+	stdgen <- getStdGen
+	putStrLn $ decode (enigma stdgen) key (encode (enigma stdgen) key "TESTINGTESTING")
+

@@ -0,0 +1,33 @@+-- | A monad to handle economic transactions between computations
+module Acme.Money (Money, lift', charge, purchase, runMoneys) where
+
+import Control.Monad.Reader
+import Control.Monad.Trans
+import Data.IORef
+
+newtype Money u t = Money { unMoney :: ReaderT (Int{-current-}, Int{-purchaser-}, [(IORef Float{-balance-}, Money u u{-computation-})]) IO t }
+
+instance Monad (Money u) where
+	return = Money . return	
+	Money m >>= f = Money $ m >>= unMoney . f
+
+-- | Lift an IO computation into the Money monad
+lift' = Money . lift
+
+-- | Charge n simoleons from the purchasing computation
+charge n =
+	if n < 0 then
+		error "Charity begins at home"
+	else
+		Money (ask >>= \(i, j, ls) -> let ref = fst (ls !! j) in
+			lift $ readIORef ref >>= \m ->
+				if m >= n then
+					writeIORef ref (m - n) >> modifyIORef (fst (ls !! i)) (+n)
+				else
+					error "Wallet lint")
+
+-- | Purchase the ith computation from the list
+purchase i = Money (ask >>= \(j, _, ls) -> lift $ runReaderT (unMoney $ snd (ls !! i)) (i, j, ls))
+
+-- | Run several computations, where the computations may purchase the use of one another
+runMoneys ls = map (\(i, (_, m)) -> runReaderT (unMoney m) (i, -1, ls)) (zip [0..] ls)

@@ -0,0 +1,47 @@+{-# LANGUAGE DeriveDataTypeable #-}
+
+-- | An interface to continuations using Peirce's law
+--
+-- This module is bogus, as the following proof demonstrates:
+--
+--   peirce (\f -> f 1 == f 2) == 1
+--
+--   peirce (\f -> f 2 == f 1) == 2
+--
+--   f 1 == f 2
+--   
+--   Therefore, 1 == 2.
+module Acme.Peirce (falseVoid, peirce, lem, doubleNeg) where
+
+import System.IO.Unsafe
+import Data.Void
+import Data.Typeable
+import Control.Concurrent.MVar
+import Control.Exception
+import Prelude hiding (catch)
+
+data ContinueException = ContinueException deriving (Show, Typeable)
+
+instance Exception ContinueException
+
+-- | Ex falso
+falseVoid :: Void -> a
+falseVoid x = x `seq` undefined
+
+-- | Peirce's law
+peirce f = unsafePerformIO $ do
+	mvar <- newEmptyMVar
+	catch
+		(return $! f $ \x -> unsafePerformIO $ do
+			putMVar mvar $! x
+			throwIO ContinueException)
+		$ \ContinueException -> tryTakeMVar mvar
+			>>= maybe (throwIO ContinueException) return
+
+-- | Law of excluded middle
+lem :: (a -> b) -> ((a -> Void) -> b) -> b
+lem f g = peirce $ \h -> g $ h . f
+
+-- | Double negation law
+doubleNeg f = lem id (falseVoid . f)
+

@@ -0,0 +1,13 @@+-- The Perhaps monad
+module Acme.Perhaps where
+
+data Perhaps t = Definitely t | Probably t | ProbablyNot | Nope deriving (Eq, Ord, Show, Read)
+
+instance Monad Perhaps where
+	return = Definitely
+	Definitely x >>= f = f x
+	Probably x >>= f = case f x of
+		Definitely y -> Probably y
+		_ -> f x
+	ProbablyNot >>= _ = ProbablyNot
+	Nope >>= _ = Nope

@@ -0,0 +1,55 @@+{-# LANGUAGE NoMonomorphismRestriction #-}
+
+module Acme.Pirates where
+
+import System.IO
+import System.Exit
+import Control.Exception
+import Prelude hiding (catch)
+
+forPlunder = ReadMode
+
+forSafeKeeping = WriteMode
+
+digUpChest = openFile
+
+buryChest = hClose
+
+loadDoubloon = hGetChar
+
+loadCashBox = hGetLine
+
+stowDoubloon = hPutChar
+
+stowCashBox = hPutStrLn
+
+readTreasureMap = hTell
+
+xMarksTheSpot = hSeek
+
+loadTheTreasure = hGetContents
+
+abandonShip = exitWith
+
+whatSayYe = getLine
+
+collectDoubloon = getChar
+
+pollySquawks = putChar
+
+pollySays = putStr . ("Yar. " ++)
+
+captainsLog = hPutStr stderr
+
+-- The crew gives the captain the black spot to inform him of a mutiny.
+theBlackSpot = throwIO
+
+-- The captain tries to give orders in the first parameter. This may result in a mutiny, which is handled in the second parameter.
+mutiny = catch
+
+-- Miscellaneous interjections
+shiverMeTimbers = id
+
+yar = id
+
+meMateys = id

@@ -0,0 +1,12 @@+module Acme.Smash where
+
+import Data.List
+import Data.Maybe
+import Control.Monad
+import Data.List.Extras.Argmax
+
+-- | smash "THE ONE" "NEO" == "THE ONEO"
+smash s s2 = fst $ argmax (\(x, y) -> length x * y) [ let Just (x, y) = find (\(_, tl2) -> isPrefixOf tl2 tl) $ zip (inits it) (tails it) in
+	(x ++ tl, length y)
+	| it <- inits s, tl <- tails s2 ]
+

@@ -0,0 +1,10 @@+module Acme.Trivial where
+
+data Trivial t = Trivial deriving (Eq, Ord, Show, Read)
+
+instance Functor Trivial where
+	fmap _ Trivial = Trivial
+
+instance Monad Trivial where
+	return _ = Trivial
+	Trivial >>= _ = Trivial

@@ -0,0 +1,30 @@+module Acme.Unit where
+
+import Control.Monad.Identity (Identity(Identity))
+
+-- /Generalized unit types/
+
+class Unit t where
+	unit :: t
+
+instance Unit () where
+	unit = ()
+
+instance (Unit t, Unit u) => Unit (t, u) where
+	unit = (unit, unit)
+
+instance (Unit t, Unit u, Unit v) => Unit (t, u, v) where
+	unit = (unit, unit, unit)
+
+instance (Unit t, Unit u, Unit v, Unit w) => Unit (t, u, v, w) where
+	unit = (unit, unit, unit, unit)
+
+instance (Unit t, Unit u, Unit v, Unit w, Unit x) => Unit (t, u, v, w, x) where
+	unit = (unit, unit, unit, unit, unit)
+
+instance (Unit t) => Unit (Identity t) where
+	unit = Identity unit
+
+instance (Unit u) => Unit (t -> u) where
+	unit = const unit
+

@@ -0,0 +1,30 @@+Copyright (c) 2015, James Candy
+
+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 James Candy nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain