diff options
| author | Mirek Kratochvil <exa.exa@gmail.com> | 2023-02-26 16:58:56 +0100 |
|---|---|---|
| committer | Mirek Kratochvil <exa.exa@gmail.com> | 2023-02-26 16:58:56 +0100 |
| commit | bb40a4f8ca6d837f3ce85ab49e7d892c96ae6b1c (patch) | |
| tree | 0e478b2301cdcaa35d896629768aa20a0c62d3cd /app/Code.hs | |
| parent | 27494c044e54f1bfe8fac466f9416b6e17d58b4d (diff) | |
| download | prlg-bb40a4f8ca6d837f3ce85ab49e7d892c96ae6b1c.tar.gz prlg-bb40a4f8ca6d837f3ce85ab49e7d892c96ae6b1c.tar.bz2 | |
yolo version
Diffstat (limited to 'app/Code.hs')
| -rw-r--r-- | app/Code.hs | 58 |
1 files changed, 1 insertions, 57 deletions
diff --git a/app/Code.hs b/app/Code.hs index 4473287..684686f 100644 --- a/app/Code.hs +++ b/app/Code.hs @@ -23,7 +23,7 @@ data Instr | Invoke Builtin -- give control to a builtin (invoked from head) | Done -- all done, can return | Cut -- remove choicepoints of the current goal - | Choices [[Code]] -- split off several possibilities (push choicepoints) + | Choices [Code] -- split off several possibilities (push choicepoints) deriving (Show) type Code = [Instr] @@ -77,59 +77,3 @@ data Builtin = instance Show Builtin where show _ = "Builtin _" - -data Dereferenced - = FreeRef Int - | BoundRef Int Datum - | NoRef - deriving (Show, Eq) - --- TRICKY: HeapRefs alone must not form a cycle other than the FreeRef case. -derefHeap :: Heap -> Int -> Dereferenced -derefHeap h@(Heap _ hmap) x = - case hmap M.!? x of - Just (HeapRef x') -> - if x == x' - then FreeRef x' - else derefHeap h x' - Just x' -> BoundRef x x' - _ -> NoRef - -writeHeap :: Int -> Datum -> Heap -> Heap -writeHeap addr x (Heap nxt m) = Heap nxt (M.adjust (const x) addr m) - -newHeapVar :: Heap -> (Heap, Int) -newHeapVar heap = head <$> newHeapVars 1 heap - -newHeapVars :: Int -> Heap -> (Heap, [Int]) -newHeapVars n (Heap nxt m) = - let addrs = [nxt + i - 1 | i <- [1 .. n]] - in ( Heap (nxt + n) $ - foldr (uncurry M.insert) m [(a, HeapRef a) | a <- addrs] - , addrs) - -withNewHeapStruct :: Int -> Datum -> Heap -> ([Datum] -> Heap -> a) -> a -withNewHeapStruct addr s@(Struct Id {arity = arity}) heap cont = - let (Heap nxt' m', addrs) = newHeapVars (arity + 1) heap - m'' = M.insert addr (HeapRef $ head addrs) . M.insert (head addrs) s $ m' - in cont (map HeapRef $ tail addrs) (Heap nxt' m'') - -heapStruct :: - Monad m - => (Datum -> m a) - -> (Datum -> [a] -> m a) - -> (Datum -> Int -> m a) - -> Heap - -> Int - -> m a -heapStruct atom struct rec (Heap _ heap) hr = go [hr] hr - where - go visited ref - | rr@(HeapRef r) <- heap M.! ref = - if r == ref || r `elem` visited - then rec rr ref - else go (r : visited) r - | s@(Struct (IR.Id _ arity)) <- heap M.! ref = - sequence [go (ref + i : visited) (ref + i) | i <- [1 .. arity]] >>= - struct s - | x <- heap M.! ref = atom x |
