mirror of
https://github.com/osmarks/random-stuff
synced 2024-09-07 21:16:47 +00:00
Group theory for strings
This commit is contained in:
parent
72c242d0a9
commit
34a370f242
@ -57,4 +57,5 @@ This comes with absolutely no guarantee of support or correct function, although
|
||||
* `rotating_audio.py` - composite audio files such that they sound as if they are from sources orbiting you
|
||||
* `nn.sql` - half an RNN in SQLite, unfinished because it *apparently* can't do recursive common table expressions.
|
||||
* `alexandergriffing_spite.py` - spites sometime by doing bad numerics in Python.
|
||||
* `screensaver.html` - an attempt to replicate one of Apple's screensavers (incomplete).
|
||||
* `screensaver.html` - an attempt to replicate one of Apple's screensavers (incomplete).
|
||||
* `StringGroup.hs` - native Haskell strings are only a monoid, so I improved them to be a group instead.
|
60
StringGroup.hs
Normal file
60
StringGroup.hs
Normal file
@ -0,0 +1,60 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module StringGroup where
|
||||
|
||||
import Test.QuickCheck
|
||||
|
||||
data SChar = P Char | N Char deriving (Eq, Ord, Show)
|
||||
newtype SString = SString [SChar] deriving (Eq, Ord, Show)
|
||||
|
||||
instance Arbitrary SChar where
|
||||
arbitrary = oneof [fmap P arbitrary, fmap N arbitrary]
|
||||
|
||||
instance Arbitrary SString where
|
||||
arbitrary = fmap (<> mempty) $ sized $ fmap SString . vector
|
||||
|
||||
instance Semigroup SString where
|
||||
(SString xs) <> (SString ys) = SString (reverse $ go zs [])
|
||||
where
|
||||
zs = xs <> ys
|
||||
go [] acc = acc
|
||||
go ((N x):xs) ((P y):ys)
|
||||
| x == y = go xs ys
|
||||
| otherwise = go xs (N x:P y:ys)
|
||||
go ((P x):xs) ((N y):ys)
|
||||
| x == y = go xs ys
|
||||
| otherwise = go xs (P x:N y:ys)
|
||||
go (x:xs) acc = go xs (x:acc)
|
||||
|
||||
concat' [] [] = []
|
||||
concat' [] ys = ys
|
||||
concat' xs [] = xs
|
||||
concat' (x:xs) ys = x:concat' xs ys
|
||||
|
||||
instance Monoid SString where
|
||||
mempty = SString []
|
||||
|
||||
positive = SString . map P
|
||||
negateSChar (P x) = N x
|
||||
negateSChar (N x) = P x
|
||||
inverse (SString s) = SString $ reverse $ map negateSChar s
|
||||
|
||||
prop_associative :: SString -> SString -> SString -> Bool
|
||||
prop_associative xs ys zs = (xs <> ys) <> zs == xs <> (ys <> zs)
|
||||
prop_leftIdentity :: SString -> Bool
|
||||
prop_leftIdentity xs = mempty <> xs == xs
|
||||
prop_rightIdentity :: SString -> Bool
|
||||
prop_rightIdentity xs = xs <> mempty == xs
|
||||
prop_leftInverse xs = inverse xs <> xs == mempty
|
||||
prop_rightInverse xs = xs <> inverse xs == mempty
|
||||
|
||||
return []
|
||||
tests = $forAllProperties $
|
||||
quickCheckWithResult (stdArgs {maxSuccess = 10000})
|
||||
|
||||
main = do
|
||||
let x = positive "hello world!"
|
||||
let y = inverse $ positive " world!"
|
||||
print (x <> y)
|
||||
|
||||
tests
|
Loading…
Reference in New Issue
Block a user