Add curvature-coloring.

1 files changed, 39 insertions, 0 deletions

diff --git a/SmallRing.hs b/SmallRing.hs
new file mode 100644
index 0000000..d792899
--- /dev/null
+++ b/SmallRing.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE RankNTypes #-}
+module SmallRing where
+
+import Data.Ratio
+
+odds :: (Integral i, Num a) => i -> [a]
+odds x = [ 1 + 2 * fromIntegral n | n <- [0..x] ]
+
+pts :: (Fractional a, Integral b) => b -> [a]
+pts i = let d = 2^i in [ k / d | k <- odds (2^(i-1) - 1) ]
+
+fractions :: Fractional b => [b]
+fractions = concatMap pts [1..]
+
+vis :: Int -> Ratio Int -> [Char]
+vis w α = let i = numerator α
+              n = denominator α
+              x = (w * i) `div` n
+           in replicate (x-1) '.' ++ "x" ++ replicate (w-max x 1) '.' ++ show α
+
+data Giver a
+    = Give0
+    | Give1 (forall b. (a -> b) -> b)
+    | Give2 (forall b. (a -> a -> b) -> b)
+    | Give3 (forall b. (a -> a -> a -> b) -> b)
+
+pushFront :: a -> Giver a -> Giver a
+pushFront a Give0     = Give1 ($ a)
+pushFront a (Give1 f) = Give2 (\g -> f (g a))
+pushFront a (Give2 f) = Give3 (\g -> f (g a))
+pushFront a (Give3 f) = f $ \b c _ -> Give3 $ \g -> g a b c
+
+take3 :: (a -> a -> a -> b) -> Giver a -> Maybe b
+take3 f (Give3 g) = Just (g f)
+take3 _ _         = Nothing
+
+with3 :: Applicative f => Giver a -> (a -> a -> a -> f ()) -> f ()
+with3 (Give3 g) f = g f
+with3 _ _         = pure ()