Group theory for strings

README.md

@@ -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.

StringGroup.hs

@@ -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