Measure the area of fractals in Lambda Screen

readme.md

More info in blog post.

Run with

ghc -threaded -O2 -rtsopts measure.hs
cat pi.blc | ./measure +RTS -N

You may also be interested in an Effekt variant using effectful NbE: https://gist.github.com/marvinborner/44236c67bbcfdaa184f37bc9b784a73f

measure.hs

import           Control.Parallel.Strategies    ( parMap
                                                , rdeepseq
                                                )
import           Data.List                      ( (!?) )
import           Data.Map                       ( Map )
import qualified Data.Map                      as Map

data Term = Abs Int Term | App Term Term | Var Int
data HTerm = HAbs (HTerm -> HTerm) | HApp HTerm HTerm | HVar Int

maxLayer :: Int
maxLayer = 4

app :: HTerm -> HTerm -> HTerm
app (HAbs f) = f
app f        = HApp f

higher :: Term -> HTerm
higher = go Map.empty
 where
  go env (Var x) = case Map.lookup x env of
    Just v -> v
    _      -> HVar x
  go env (Abs n t) = HAbs $ \x -> go (Map.insert n x env) t
  go env (App a b) = app (go env a) (go env b)

lower :: HTerm -> Term
lower = go 0
 where
  go _ (HVar v  ) = Var v
  go d (HAbs t  ) = Abs d $ go (d + 1) (t (HVar d))
  go d (HApp a b) = App (go d a) (go d b)

screens :: Term -> Maybe [Term]
screens (Abs n t) = go t
 where
  go (App a b)        = (b :) <$> go a
  go (Var v) | v == n = Just []
  go _                = Nothing
screens _ = Nothing

isPerfect :: Int -> Bool
isPerfect n = square * square == n
  where square = floor $ sqrt (fromIntegral n :: Double)

isWhite :: Term -> Bool
isWhite (Abs n (Abs _ (Var v))) = n == v
isWhite _                       = False

isBlack :: Term -> Bool
isBlack (Abs _ (Abs n (Var v))) = n == v
isBlack _                       = False

area :: Int -> Double -> HTerm -> Double
area maxLayer = go 0
 where
  go layer size _ | layer > maxLayer = 0
  go layer size t                    = case screens t' of
    Just s | isPerfect (length s) -> do
      let slice = size / (fromIntegral (length s) :: Double)
      sum $ parMap rdeepseq (go (layer + 1) slice . higher) s -- parallel `sum $ map (go slice . higher) s`
    Nothing | isBlack t' -> size -- here we only count black area, you can modify this of course!
            | isWhite t' -> 0
            | otherwise  -> error "invalid screen"
    where t' = lower t

-- | quick'n'dirty BLC parser
fromBinary :: String -> Term
fromBinary = fst . go [] 0
 where
  go env n inp = case inp of
    '0' : '0' : rst -> do
      let (e, rst1) = go (n : env) (n + 1) rst
      (Abs n e, rst1)
    '0' : '1' : rst -> do
      let (a, rst1) = go env n rst
      let (b, rst2) = go env n rst1
      (App a b, rst2)
    '1' : rst -> do
      let idx = length (takeWhile (== '1') rst)
      case env !? idx of
        Just v  -> (Var v, drop (idx + 1) rst)
        Nothing -> error "open term"
    _ -> error $ "invalid " ++ inp

main :: IO ()
main = do
  blc <- getContents
  let t = fromBinary blc
  let x = area maxLayer 1.0 $ higher $ App t (Var 0)
  print $ (1 - x) * 4

pi.blc

00010100011010000000010111001110000110010111110111100000011100111001011111101101000000101111000001010000001110011100111010