misc: add more scripts

misc/Set.hs

@@ -0,0 +1,145 @@
+{-# LANGUAGE TypeSynonymInstances, TypeFamilies #-}
+module Set where
+
+import Data.Char
+import Data.Complex
+import qualified GHC.Exts as Exts
+
+import Prelude hiding (filter)
+import qualified Prelude
+import Data.Functor.Contravariant
+import qualified Data.Functor.Contravariant.Divisible as Divisible
+import Data.Isomorphism
+
+liftP :: (Bool -> Bool) -> Predicate a -> Predicate a
+liftP op p = Predicate $ op <$> getPredicate p
+
+liftP2 :: (Bool -> Bool -> Bool) -> Predicate a -> Predicate a -> Predicate a
+liftP2 op p q = Predicate $ op <$> getPredicate p <*> getPredicate q
+
+type Set = Predicate
+
+instance (Eq a) => Exts.IsList (Set a) where
+    type Item (Set a) = a
+    fromList = fromFoldable
+    toList = undefined
+
+(\\) :: Set a -> Set a -> Set a
+(\\) = difference
+
+(\/) :: Set a -> Set a -> Set a
+(\/) = union
+
+(/\) :: Set a -> Set a -> Set a
+(/\) = intersection
+
+cantor :: (a -> Set a) -> Set a
+cantor = Predicate . (<*>) notMember
+
+cartesian :: Set a -> Set b -> Set (a, b)
+cartesian = Divisible.divided
+
+complement :: Set a -> Set a
+complement = liftP not
+
+containing :: a -> Set (Set a)
+containing = Predicate . member
+
+delete :: (Eq a) => a -> Set a -> Set a
+delete x m = m \\ singleton x
+
+difference :: Set a -> Set a -> Set a
+difference = liftP2 (\x y -> x && not y)
+
+disjointUnion :: Set a -> Set b -> Set (Either a b)
+disjointUnion = Divisible.chosen
+
+empty :: Set a
+empty = Predicate $ const False
+
+universal :: Set a
+universal = mempty
+
+filter :: (a -> Bool) -> Set a -> Set a
+filter f m = Predicate $ (&&) <$> getPredicate m <*> f
+
+fromFoldable :: (Foldable t, Eq a) => t a -> Set a
+fromFoldable = Predicate . flip elem
+
+insert :: (Eq a) => a -> Set a -> Set a
+insert = union . singleton
+
+intersection :: Set a -> Set a -> Set a
+intersection = liftP2 (&&)
+
+member :: a -> Set a -> Bool
+member = flip getPredicate
+
+notMember :: a -> Set a -> Bool
+notMember = (not .) . member
+
+partition :: (a -> Bool) -> Set a -> (Set a, Set a)
+partition f m = (filter f m, filter (not . f) m)
+
+singleton :: (Eq a) => a -> Set a
+singleton = Predicate . (==)
+
+split :: (Ord a) => a -> Set a -> (Set a, Set a)
+split pivot m = (filter (< pivot) m, filter (> pivot) m)
+
+splitMember :: (Ord a) => a -> Set a -> (Set a, Bool, Set a)
+splitMember pivot m = let (ls, gs) = split pivot m in (ls, member pivot m, gs)
+
+toList :: (Enum a, Bounded a) => Set a -> [a]
+toList m = Prelude.filter (getPredicate m) [minBound .. maxBound]
+
+union :: Set a -> Set a -> Set a
+union = liftP2 (||)
+
+unions :: (Foldable t) => t (Set a) -> Set a
+unions = foldr union empty
+
+naturals :: (Ord a, Integral a) => Set a
+naturals = Predicate (>= 0)
+
+reals :: (Real a) => Set a
+reals = universal
+
+rationals :: (Fractional a) => Set a
+rationals = universal
+
+integers :: (Integral a) => Set a
+integers = universal
+
+complexes :: (Real a) => Set (Complex a)
+complexes = universal
+
+mapIso :: Iso (->) a b -> Set a -> Set b
+mapIso = contramap . project
+
+digit :: Iso (->) Int Char
+digit = Iso intToDigit digitToInt
+
+casePreserving :: (String -> String) -> String -> String
+casePreserving f = applyCasing <$> map isUpper <*> f
+    where applyCasing = zipWith (bool toUpper toLower)
+          bool x y b = if b then x else y
+
+main = do
+  let sampleSet = fromFoldable [0 .. 9]
+  let digitSet = mapIso digit sampleSet
+  print (toList digitSet)
+
+shorten :: String -> String
+shorten word
+  | n <= 10 = word
+  | otherwise = [head word] ++ show (n - 2) ++ [last word]
+  where
+    n = length word
+
+lev :: (Eq a) => [a] -> [a] -> Int
+lev [] ys = length ys
+lev xs [] = length xs
+lev xxs@(x:xs) yys@(y:ys)
+  | x == y = lev xs ys
+  | otherwise = 1 + minimum [lev xs yys, lev xxs ys, lev xs ys]