1 files changed, 86 insertions, 73 deletions

diff --git a/src/Optimizer.hs b/src/Optimizer.hs
index 260c149..b458eb3 100644
--- a/src/Optimizer.hs
+++ b/src/Optimizer.hs
@@ -1,86 +1,99 @@
 -- MIT License, Copyright (c) 2024 Marvin Borner
--- Ultimately, the optimizer should not be outsourced but handled directly in Haskell.
--- For now, my BLoC format is used in combination with BLoCade the BLoC-aid.
-
 module Optimizer
-  ( optimizeToTarget
-  , optimizedReduce
+  ( optimizedReduce
   ) where
 
-import           Binary
-import           Control.Exception
-import qualified Data.BitString                as Bit
-import qualified Data.ByteString.Lazy.Char8    as Byte
+import qualified Data.Map                      as M
 import           Helper
 import           Reducer
-import           System.IO
-import           System.Process
 
-tryIO :: IO a -> IO (Either IOException a)
-tryIO = try
+data Direction = L | D | R
+  deriving (Show, Eq)
+type Path = [Direction] -- will be reversed
+type Tree = M.Map Expression [Path]
+
+resolvePath :: Expression -> Path -> Maybe Expression
+resolvePath e                 []      = Just e
+resolvePath (Application l _) (L : p) = resolvePath l p
+resolvePath (Application _ r) (R : p) = resolvePath r p
+resolvePath (Abstraction t  ) (D : p) = resolvePath t p
+resolvePath _                 _       = Nothing
+
+constructTree :: Expression -> Tree
+constructTree = go [] M.empty
+ where
+  go p m e@(Application l r) = do
+    let m'  = go (L : p) m l
+    let m'' = go (R : p) m' r
+    M.insertWith (++) e [p] m''
+  go p m e@(Abstraction t) = do
+    let m' = go (D : p) m t
+    M.insertWith (++) e [p] m'
+  go p m e@(Bruijn i) = M.insertWith (++) e [p] m
+  go _ _ _            = invalidProgramState
+
+isClosed :: Expression -> Bool
+isClosed = go 0
+ where
+  go i (Bruijn j       ) = i > j
+  go i (Application l r) = go i l && go i r
+  go i (Abstraction t  ) = go (i + 1) t
+  go _ _                 = True
+
+-- (kinda arbitrary)
+isGood :: Expression -> Bool
+isGood = go 10
+ where
+  go 0 _                               = True
+  go i (Application (Abstraction l) r) = go (i - 2) l || go (i - 2) r
+  go i (Application l               r) = go (i - 1) l || go (i - 1) r
+  go i (Abstraction t                ) = go (i - 1) t
+  go _ _                               = False
 
--- toBloc :: Expression -> IO (Failable Handle)
--- toBloc e = do
---   let binary = toBinary e
---   tryBloc <- tryIO $ createProcess (proc "bloc" ["-i", "-", "--from-blc"])
---     { std_in  = CreatePipe
---     , std_out = CreatePipe
---     }
---   let bloc = case tryBloc of
---         Right (Just i, Just o, _, _) -> Just (i, o)
---         _                            -> Nothing
---   case bloc of
---     Just (inH, outH) -> do
---       hPutStrLn inH binary
---       return $ Right outH
---     Nothing -> return $ Left $ OptimizerError "can't read/write to bloc"
+-- if expression has a parent that appears more often
+preferParent :: Expression -> [Path] -> Tree -> Bool
+preferParent e ps t = do
+  let len = length ps
+  any
+    (\p -> any
+      (\p' -> case resolvePath e p' of
+        Just r  -> length (M.findWithDefault [] r t) >= len
+        Nothing -> False
+      )
+      [R : p, D : p, L : p]
+    )
+    ps
 
-toTarget :: Expression -> String -> IO (Failable String)
-toTarget e target = do
-  res <- tryIO $ createProcess_
-    ""
-    (shell $ "bloc -v -i - --from-blc | blocade -v -i - -t " <> target)
-      { std_in  = CreatePipe
-      , std_out = CreatePipe
-      }
-  case res of
-    Right (Just inH, Just outH, _, _) -> do
-      let binary = toBinary e
-      hSetBuffering inH  NoBuffering
-      hSetBuffering outH NoBuffering
-      hSetBinaryMode outH True
-      hIsOpen inH >>= print
-      hIsWritable inH >>= print
-      hPutStrLn inH binary
-      hFlush inH
-      content <- hGetContents' outH
-      return $ case content of
-        "" -> Left $ OptimizerError "blocade returned empty string"
-        _  -> Right content
-    _ -> return $ Left $ OptimizerError "can't read from blocade"
+commonPath :: Path -> Path -> Path
+commonPath p1 p2 = go (reverse p1) (reverse p2)
+ where
+  go _  [] = []
+  go [] _  = []
+  go (x : xs) (y : ys) | x == y    = x : go xs ys
+                       | otherwise = []
 
--- TODO: add more targets (including other PL compilation)
-toExpression :: String -> String -> Expression
-toExpression "blc"   = fromBinary
-toExpression "unblc" = fromBinary
-toExpression "bblc" =
-  fromBinary . fromBitString . Bit.bitStringLazy . Byte.pack
-toExpression "unbblc" =
-  fromBinary . fromBitString . Bit.bitStringLazy . Byte.pack
-toExpression _ = invalidProgramState
+inject :: Expression -> Path -> Expression -> [Path] -> Expression
+inject i [] e ps = Application (Abstraction (subst ? (incv e))) i
+inject i [L : p] (Application l r) ps = Application (inject i p l ps) r
+inject i [R : p] (Application l r) ps = Application l (inject i p r ps)
+inject i [D : p] (Abstraction t  ) ps = Abstraction (inject i p t ps)
+inject _ _       _                 _  = invalidProgramState
 
-optimizeToTarget :: EvalConf -> Expression -> IO Expression
-optimizeToTarget conf e = do
-  let target = _optimizeTarget conf
-  case target of
-    "" -> return e -- No target, fallback to unoptimized expression
-    _  -> do
-      maybeRes <- toTarget e target
-      case maybeRes of
-        Left err -> do
-          print err
-          return e -- Fallback to unoptimized expression
-        Right res -> return $ toExpression target res
+optimize :: Expression -> IO Expression
+optimize e = do
+  let tree = constructTree e
+  let filtered =
+        M.filterWithKey (\k ps -> isClosed k && isGood k && length ps > 1) tree
+  let filtered' =
+        M.filterWithKey (\k ps -> not $ preferParent e ps filtered) filtered
+  -- TODO: simulated annealing just before injection
+  print $ (\(k, p) -> foldl1 commonPath p) <$> M.toList filtered'
+  -- inject t (take (length commonPath) ps) e ps -- oder so
+  pure e
+-- optimize e = constructTree e
 
+-- TODO: enable optimizer with flag
 optimizedReduce :: EvalConf -> Expression -> IO Expression
-optimizedReduce conf e = optimizeToTarget conf e >>= reduce conf
+optimizedReduce conf e = do
+  optimize e
+  reduce conf e