From c9fa374008d124a7a83443d952bd146662dcffa5 Mon Sep 17 00:00:00 2001
From: ProgramSnail <purpurebacterium@yandex.ru>
Date: Tue, 2 Sep 2025 22:39:32 +0300
Subject: [PATCH] iteration ,prev versions save

---
 main.hs | 238 +++++++++++++++++++++++++++++++++-----------------------
 v1.hs   |  57 ++++++++++++++
 v2.hs   | 105 +++++++++++++++++++++++++
 v3.hs   |  41 ++++++++++
 4 files changed, 344 insertions(+), 97 deletions(-)
 create mode 100644 v1.hs
 create mode 100644 v2.hs
 create mode 100644 v3.hs

diff --git a/main.hs b/main.hs
index 1d48ada..fc06bd1 100644
--- a/main.hs
+++ b/main.hs
@@ -1,63 +1,10 @@
-import Data.Map.Strict as Map
+import Data.Bifunctor as Bifunctor
+import Data.Maybe as Maybe
+import Control.Monad as Monad
 
 type Symb = String
 infixl 4 :@:
 
--- data Type = Boo
---           | Type :-> Type
---           | BoxT Symb Type -- is type required ??
---     deriving (Read,Show,Eq)
-
--- -- TODO: integrate into match
--- data SymbType = SymbIn -- simple 'argument'
---               | SymbOut -- exported from inside function to outer context by export
---               | SymbRef -- In + Out
-
--- data CtxType = PreviousCtx
---              | NewCtx
-
--- data Term = Fls
---           | Tru
---           | Var Symb
---           | Box SymbType Symb Type
---           | Export Symb Type
---           | Term :@: Term
---           | Match Term Term Term -- match _ : T then _ else _
---           -- Box s t (variable place) = Match SymbIn 
---           deriving (Read,Show)
-
--- type Ctx = Map Symb Term
-
--- assign :: Term -> Term -> Maybe Ctx
-
--- assign Fls Fls = Just []
--- assign Tru Tru = Just []
--- assign (Idx i) (Idx j) | i == j = Just []
--- assign (Box x _) t = Just [t] -- TODO: remember name
--- assign (left :@: right) (left' :@: right') = do ctxLeft <- assign left left' -- TODO: ??
---                                                 ctxRight <- assign right right'
---                                                 Just $ ctxLeft ++ ctxRight 
--- -- assign (Match pattern t doThen deElse) term = case assign pattern term of -- TODO: ??
--- --                                                 Just ctx -> doThen
--- --                                                 Nothing -> doElse
--- assign _ _ = Nothing
-
--- -- need to extend context in some way
--- -- context effect ??
-
--- -- TODO
--- subst :: Ctx -> Term -> Term
-
--- -- TODO
--- oneStep :: Term -> Maybe Term
--- oneStep _ = Nothing
-
--- -- TODO
--- whnf :: Term -> Term
--- whnf u = maybe u whnf (oneStep u)
-
--------------------------------------------------------------------------
-
 -- %x + 3 := 12
 -- addp :: BoxT Int -> Int -> Int -> ???
 -- addp :: Out Int -> In Int -> In Int
@@ -67,59 +14,156 @@ infixl 4 :@:
 -- addp (Box x Int) 3 <- type ??? {_: Int} -> {x: Int}
 -- Match ((+') (Box x Int) 3) 12
 
--- TODO: proper types for all nodes
+--------------------------------
+--
+-- idea: every function returns context (list/map of named terms instead of expr)
+-- Branch - split current entity on two subcontexts
+-- Name - name current branch
+
+-- context is a function ?
+-- matching rules:
+-- Ctx Ctx -> apply in elements
+-- Fls Fls, Tru Tru -> matched, []
+-- Name:Type Term:Type -> matched, [name:term]
+-- Union, Context, Var - should have been reduced
+-- Match Term -> apply match to term, propogate result
+
+-- context -> tuple
+
 data Type = Boo
+          | BoxT Type
           | Type :-> Type
-          | BoxT Symb Type
+          | TupleT [Type]
+  deriving (Read, Show, Eq)
 
-type Ctx = Map Symb Term
+type TermTuple = [Term]
+type TypeTuple = [Type]
 
-data Term = Fls
-          | Tru
-          | OpenContext {ctx :: Term, term :: Term}
-          | GetFromContext {x :: Symb, ctx :: Term}
-          | Context Ctx
-          | Var Symb
-          | Box Symb Type
-          | Term :@: Term
-          | Match {pattern :: Term, doThen :: Term, doElse :: Term}
+maybeMapToMaybe :: [Maybe a] -> Maybe [a]  -- NOTE: probably can be replaced from stdlib
+maybeMapToMaybe = foldl (\res x -> case x of
+                                     Just x -> (:) x <$> res
+                                     Nothing -> Nothing) (Just [])
 
-assign :: Term -> Term -> Maybe Ctx
-assign Fls Fls = Just Map.empty
-assign Tru Tru = Just Map.empty
--- assign (OpenContext ctx term) term = Just Map.empty -- TODO ?? no meaning, should have been evaluated
--- assign (GetFromContext x ctx) term = Just Map.empty -- TODO ?? no meaning, should have biie evaluated
--- assign (Context ctx) term = Just Map.empty -- TODO ?? can't assign term, no meaning ??
-assign (Var x) (Var y) | x == y = Just Map.empty
-assign (Box x t) term = Just $ Map.singleton x term
--- assign (left :@: right) (left' :@: right') = do ctxLeft <- assign left left' -- TODO: ?? probably should hav been evaluated first
---                                                 ctxRight <- assign right right'
---                                                 Just $ Map.union ctxLeft ctxRight 
-assign match@(Match {}) term = case whnf (match :@: term) of
-                                 Context ctx -> Just ctx
-                                 _ -> Nothing
+-- TODO: put something into empty branches / replace branching with another solution
+-- TODO: how to return names from context <- return indexed list
+data Term = Fls -- const
+          | Tru -- const
+          -- | Empty -- empty context -- replaced with Tuple []
+          | Box Type -- encode pattern entities
+          -- | Merge Term Term -- union resulting contexts -- replaced with :@:
+          | Tuple TermTuple -- resulting contet as elem of context
+          | Var Int -- get variable from current context
+          | Match {pat :: Term, doThen :: Term, doElse :: Term} -- match context with pattern and exec body, should be applied to term=ctx
+          | Term :@: Term -- apply term to term
+  deriving (Read, Show)
+
+-- \x:Boo -> if x then Fls else Sru
+-- ~same to (?):
+-- Match (Box:Boo) ((Match Tru Fls Tru) (Var 0)) Empty
+--
+-- pattern matching (use contexts as tuples / lists):
+-- Match (Union (Context Box:Boo) (Context Box:Boo)) ... <- pattern match pair
+--
+-- complex pattern:
+-- Match (Union (Context Box:Boo) (Match (Tru) (Union (Context Tru) (Context Tru)) (Union (Context Fls) (Context Fls))) ... <- match pair, match second elem with Tru. Note that context size = 3 after 
+
+assign :: Term -> Term -> Maybe TermTuple
+assign Fls Fls = Just []
+assign Tru Tru = Just []
+assign (Box {}) term = Just [term]
+assign (Tuple left) (Tuple right) | length left == length right = maybeMapToMaybe $ map (Tuple <$>) $ zipWith assign left right
+-- assign (Var x) term -- should be reduced (?)
+assign match@Match {pat, doThen, doElse} term | Tuple tuple <- whnf (match :@: term) = Just tuple
+-- assign (Term :@: Term) term -- should be reduced
 assign _ _ = Nothing
 
--- TODO: check
--- TODO: choose eval trategy
--- TODO: separate unsuccessful assignment and camputation error during assignment ??
+--------------------------------------------
+
+-- for patterns
+tupleSize :: Term -> Int
+tupleSize Fls = 0
+tupleSize Tru = 0
+tupleSize (Box {}) = 1
+tupleSize (Tuple ts) = length ts
+-- tupleSize (Var x) -- should be reduced (?)
+tupleSize (Match {pat, doThen, doElse}) = tupleSize doThen -- == tupleSize doElse
+-- tupleSize (t :@: u) -- should be reduced
+
+shiftFrom :: Int -> Int -> Term -> Term
+shiftFrom m k Fls = Fls
+shiftFrom m k Tru = Tru
+shiftFrom m k (Box t) = Box t -- TODO: shift type ?? <- probaby not
+shiftFrom m k (Tuple ts) = Tuple $ map (shiftFrom m k) ts
+shiftFrom m k (Var n) = if n < m then Var n else Var $ n + k
+shiftFrom m k (Match {pat, doThen, doElse}) = Match {
+  pat = shiftFrom m k pat,
+  doThen = shiftFrom (m + tupleSize pat) k doThen,
+  doElse = shiftFrom m k doElse
+}
+shiftFrom m k (left :@: right) = shiftFrom m k left :@: shiftFrom m k right
+
+shift :: Int -> Term -> Term
+shift = shiftFrom 0
+
+substDB :: Int -> Term -> Term -> Term
+substDB j s Fls = Fls
+substDB j s Tru = Tru
+substDB j s (Box t) = Box t -- TODO: subst in type ?? <- probaby not
+substDB j s (Tuple ts) = Tuple $ map (substDB j s) ts
+substDB j s (Var n) = if n == j then s else Var n
+substDB j s (Match {pat, doThen, doElse}) = let patSize = tupleSize pat in Match { -- TODO
+  pat = substDB j s pat,
+  doThen = substDB (j + patSize) (shift patSize s) doThen,
+  doElse = substDB j s doElse
+}
+substDB j s (left :@: right) =  substDB j s left :@: substDB j s right
+
 oneStep :: Term -> Maybe Term
 oneStep Fls = Nothing
 oneStep Tru = Nothing
-oneStep (OpenContext {ctx, term}) = error "not implemented yet"
-oneStep (GetFromContext {x, ctx}) | Just ctx' <- oneStep ctx = Just $ GetFromContext {x, ctx = ctx'}
-                                  | Context c <- ctx = Map.lookup x c
-oneStep (Context {}) = Nothing
-oneStep (Var {}) = Nothing
 oneStep (Box {}) = Nothing
-oneStep (left :@: right) | Just left' <- oneStep left = Just left'
-                         | Just right' <- oneStep right = Just right'
-oneStep (Match {pattern, doThen, doElse}) | Just pattern' <- oneStep pattern = Just pattern'
-                                          | Just doThen' <- oneStep doThen = Just doThen'
-                                          | Just doElse' <- oneStep doElse = Just doElse'
-oneStep (Match {pattern, doThen, doElse} :@: term) | Just c <- assign pattern term = Just doThen
-                                                   | otherwise = Just doElse
+oneStep (Tuple ts) = foldl (\res t -> case res of
+                                        Just t' -> Just t'
+                                        Nothing -> oneStep t
+                    ) Nothing ts -- or foldr ? -- TODO: step in first possible. foldl ??
+oneStep (Var {}) = Nothing
+oneStep (Match {pat, doThen, doElse}) | Just pat' <- oneStep pat = Just $ Match {pat=pat', doThen, doElse}
+oneStep (left :@: right) | Just left' <- oneStep left = Just $ left' :@: right
+                         | Just right' <- oneStep right = Just $ left :@: right'
+oneStep ((Tuple left) :@: (Tuple right)) = Just $ Tuple $ left ++ right -- TODO: check order
+-- oneStep (Match {pat, doThen, doElse} :@: term) | Just tuple <- assign pat term = -- TODO: subst context
+--                                                | otherwise = Just doElse 
+-- TODO
 oneStep _ = Nothing
 
 whnf :: Term -> Term
 whnf u = maybe u whnf (oneStep u)
+
+-------------------------------------------
+
+-- returned 'Maybe' has another meaning: is typecheck possible
+assignT :: Type -> Type -> Maybe TypeTuple
+assignT Boo Boo = Just []
+assignT (BoxT t) u = Just [u]
+assignT (t :-> u) w | t == w = Just [u] -- TODO: redifine Eq ??
+assignT (TupleT ts) (TupleT us) | length ts == length us = maybeMapToMaybe $ map (TupleT <$>) $ zipWith assignT ts us
+assignT _ _ = Nothing
+
+infer :: TypeTuple -> Term -> Maybe Type
+infer env Tru = Just Boo
+infer env Fls = Just Boo
+infer env (Box t) = Just $ BoxT t
+infer env (Tuple terms) = TupleT <$> maybeMapToMaybe $ map (infer env) terms -- TODO
+infer (Var x) = env `elem` x -- TODO
+infer env (Match {pat, doThen, doElse}) = do patT <- infer env pat
+                                         -- TODO: infer doThenT with extended context
+                                             doElseT <- infer env doElse
+                                        -- TODO: guard: doThenT == doElseT
+                                             return patT :-> doElseT -- TODO ??
+infer (left :@: right) | Just (Tuple leftTs) <- infer env left,
+                         Just (TupleT rightTs) <- infer env right = Just $ TupleT $ leftTs ++ rightTs
+                       | Just (leftTArg :-> leftTRes) <- infer env left,
+                         Just rightT <- infer env right = -- TODO: assign types, etc.
+                       -- TODO: auto make tuples from other types ??
+-- TODO
+infer _ _ = Nothing
diff --git a/v1.hs b/v1.hs
new file mode 100644
index 0000000..df67874
--- /dev/null
+++ b/v1.hs
@@ -0,0 +1,57 @@
+--- NOTE: IS NOT COMPLETED ---
+
+type Symb = String
+infixl 4 :@:
+
+data Type = Boo
+          | Type :-> Type
+          | BoxT Symb Type -- is type required ??
+    deriving (Read,Show,Eq)
+
+-- TODO: integrate into match
+data SymbType = SymbIn -- simple 'argument'
+              | SymbOut -- exported from inside function to outer context by export
+              | SymbRef -- In + Out
+
+data CtxType = PreviousCtx
+             | NewCtx
+
+data Term = Fls
+          | Tru
+          | Var Symb
+          | Box SymbType Symb Type
+          | Export Symb Type
+          | Term :@: Term
+          | Match Term Term Term -- match _ : T then _ else _
+          -- Box s t (variable place) = Match SymbIn 
+          deriving (Read,Show)
+
+type Ctx = Map Symb Term
+
+assign :: Term -> Term -> Maybe Ctx
+
+assign Fls Fls = Just []
+assign Tru Tru = Just []
+assign (Idx i) (Idx j) | i == j = Just []
+assign (Box x _) t = Just [t] -- TODO: remember name
+assign (left :@: right) (left' :@: right') = do ctxLeft <- assign left left' -- TODO: ??
+                                                ctxRight <- assign right right'
+                                                Just $ ctxLeft ++ ctxRight 
+-- assign (Match pattern t doThen deElse) term = case assign pattern term of -- TODO: ??
+--                                                 Just ctx -> doThen
+--                                                 Nothing -> doElse
+assign _ _ = Nothing
+
+-- need to extend context in some way
+-- context effect ??
+
+-- TODO
+subst :: Ctx -> Term -> Term
+
+-- TODO
+oneStep :: Term -> Maybe Term
+oneStep _ = Nothing
+
+-- TODO
+whnf :: Term -> Term
+whnf u = maybe u whnf (oneStep u)
diff --git a/v2.hs b/v2.hs
new file mode 100644
index 0000000..66dcacd
--- /dev/null
+++ b/v2.hs
@@ -0,0 +1,105 @@
+--- NOTE: IS NOT COMPLETED ---
+
+import Data.Map.Strict as Map
+import Data.Bifunctor as Bifunctor
+import Data.Maybe as Maybe
+import Control.Monad as Monad
+
+type Symb = String
+infixl 4 :@:
+
+-------------------------------------------------------------------------
+
+-- %x + 3 := 12
+-- addp :: BoxT Int -> Int -> Int -> ???
+-- addp :: Out Int -> In Int -> In Int
+-- addp :: {x: Box Int} -> {_: Int} -> {_: Int} -> ??? {x: Int}
+-- addp :: Box Int -> In Int -> In Int -> Ctx
+-- addp :: Box x Int -> Int -> Int -> {x: Int}
+-- addp (Box x Int) 3 <- type ??? {_: Int} -> {x: Int}
+-- Match ((+') (Box x Int) 3) 12
+
+type CtxT = Map Symb Type
+
+-- TODO: proper types for all nodes
+data Type = Boo
+          | Type :-> Type
+          | ContextT CtxT
+          | BoxT Symb Type
+  deriving (Read,Show,Eq)
+
+type Ctx = Map Symb Term
+
+data Term = Fls
+          | Tru
+          | OpenContext {ctx :: Term, term :: Term}
+          | GetFromContext {x :: Symb, ctx :: Term}
+          | Context Ctx
+          | Var Symb
+          | Box Symb Type
+          | Term :@: Term
+          | Match {pattern :: Term, doThen :: Term, doElse :: Term}
+  deriving (Read,Show)
+
+assign :: Term -> Term -> Maybe Ctx
+assign Fls Fls = Just Map.empty
+assign Tru Tru = Just Map.empty
+-- assign (OpenContext ctx term) term = Just Map.empty -- TODO ?? no meaning, should have been evaluated
+-- assign (GetFromContext x ctx) term = Just Map.empty -- TODO ?? no meaning, should have biie evaluated
+-- assign (Context ctx) term = Just Map.empty -- TODO ?? can't assign term, no meaning ??
+assign (Var x) (Var y) | x == y = Just Map.empty
+assign (Box x t) term = Just $ Map.singleton x term
+-- assign (left :@: right) (left' :@: right') = do ctxLeft <- assign left left' -- TODO: ?? probably should hav been evaluated first
+--                                                 ctxRight <- assign right right'
+--                                                 Just $ Map.union ctxLeft ctxRight 
+assign match@(Match {}) term = case whnf (match :@: term) of
+                                 Context ctx -> Just ctx
+                                 _ -> Nothing
+assign _ _ = Nothing
+
+-- TODO: check
+-- TODO: choose eval trategy
+-- TODO: separate unsuccessful assignment and camputation error during assignment ??
+oneStep :: Term -> Maybe Term
+oneStep Fls = Nothing
+oneStep Tru = Nothing
+oneStep (OpenContext {ctx, term}) = error "not implemented yet" -- TODO
+oneStep (GetFromContext {x, ctx}) | Just ctx' <- oneStep ctx = Just $ GetFromContext {x, ctx = ctx'}
+                                  | Context c <- ctx = Map.lookup x c
+oneStep (Context {}) = Nothing
+oneStep (Var {}) = Nothing
+oneStep (Box {}) = Nothing
+oneStep (left :@: right) | Just left' <- oneStep left = Just $ left' :@: right
+                         | Just right' <- oneStep right = Just $ left :@: right'
+oneStep (Match {pattern, doThen, doElse}) | Just pattern' <- oneStep pattern = Just pattern'
+                                          -- | Just doThen' <- oneStep doThen = Just doThen'
+                                          -- | Just doElse' <- oneStep doElse = Just doElse'
+oneStep (Match {pattern, doThen, doElse} :@: term) | Just c <- assign pattern term = Just $ OpenContext (Context c) doThen
+                                                   | otherwise = Just doElse
+oneStep _ = Nothing
+
+whnf :: Term -> Term
+whnf u = maybe u whnf (oneStep u)
+
+-----------------------
+
+-- TODO: all cases, check proper context usage
+-- all functions should return context ??, need to fill variables and use returned expression in some way
+infer :: CtxT -> Term -> Maybe Type
+infer env Tru = Just Boo
+infer env Fls = Just Boo
+infer env (OpenContext {ctx, term}) | Just (ContextT ctxT) <- infer env ctx = infer (Map.union env ctxT) term -- TODO: better intersection, properly check duplicates
+infer env (GetFromContext {x, ctx}) | Just (ContextT ctxT) <- infer env ctx = Map.lookup x ctxT
+infer env (Context ctx) = Just $ ContextT $ Map.fromList $ Maybe.mapMaybe (\(x, term) -> (,) x <$> infer env term) $ Map.toList ctx -- TODO: real context ??
+infer env (Var x) = Map.lookup x env
+infer env (Box x t) = Just $ BoxT x t -- TODO ??
+infer env (left :@: right) = error "TODO" -- let sould be match
+infer env (Match {pattern, doThen, doElse}) = let env' = env in -- TODO: context from pattern, infer assignment
+                                              let patternT = Boo in -- TODO: real type of pattern 
+                                              do  thenT <- infer env' doThen
+                                                  elseT <- infer env' doElse
+                                                  Monad.guard $ thenT == elseT
+                                                  Just $ patternT :-> thenT
+infer _ _ = Nothing
+
+
diff --git a/v3.hs b/v3.hs
new file mode 100644
index 0000000..a9585bd
--- /dev/null
+++ b/v3.hs
@@ -0,0 +1,41 @@
+import Data.Map.Strict as Map
+import Data.Bifunctor as Bifunctor
+import Data.Maybe as Maybe
+import Control.Monad as Monad
+
+type Symb = String
+infixl 4 :@:
+
+-- %x + 3 := 12
+-- addp :: BoxT Int -> Int -> Int -> ???
+-- addp :: Out Int -> In Int -> In Int
+-- addp :: {x: Box Int} -> {_: Int} -> {_: Int} -> ??? {x: Int}
+-- addp :: Box Int -> In Int -> In Int -> Ctx
+-- addp :: Box x Int -> Int -> Int -> {x: Int}
+-- addp (Box x Int) 3 <- type ??? {_: Int} -> {x: Int}
+-- Match ((+') (Box x Int) 3) 12
+
+--------------------------------
+--
+-- idea: every function returns context (list/map of named terms instead of expr)
+-- Branch - split current entity on two subcontexts
+-- Name - name current branch
+
+type Ctx = Map Symb Term
+
+data Type = Boo
+          | NameT Symb Type
+          | Type :-> Type
+          | CtxT (Map Symb Type)
+  deriving (Read,Show, Eq)
+
+data Term = Fls -- const as _
+          | Tru -- const as _
+          | Name Symb Type -- encode pattern entities
+          | Union Term -- union resulting contexts, should be applied to term=ctx
+          | Var Symb -- get variable from current context as _
+          | Context Ctx -- direct context return
+          | Lmb {pat :: Term, body :: Term} -- match context with pattern and exec body, should be applied to term=ctx
+          | Term :@: Term -- apply term to term
+  deriving (Read,Show)
+