module TransitiveClosure where
-- SPDX-FileCopyrightText: Chris Pressey, the original author of this work, has dedicated it to the public domain.
-- For more information, please refer to <https://unlicense.org/>
-- SPDX-License-Identifier: Unlicense
--
-- First some crude set theoretic functions
-- (which, unlike Data.Set, don't rely on Ord a =>)
--
insert :: Eq a => a -> [a] -> [a]
insert x xs = if x `elem` xs then xs else x:xs
union :: Eq a => [a] -> [a] -> [a]
union [] b = b
union (x:xs) b = union xs (insert x b)
subset :: Eq a => [a] -> [a] -> Bool
subset [] _ = True
subset (x:xs) other = x `elem` other && xs `subset` other
seteq :: Eq a => [a] -> [a] -> Bool
seteq a b = a `subset` b && b `subset` a
--
-- Compute f^n(x) until f^n(x) == f^(n-1)(x)
--
iterateToFixpoint :: Eq a => (a -> a) -> a -> a
iterateToFixpoint fun x
| (fun x) == x = x
| otherwise = iterateToFixpoint (fun) (fun x)
--
-- Compute the transitive closure of the function over the set
--
transitiveClosure :: Eq a => (a -> a) -> [a] -> [a]
transitiveClosure fun set
| seteq set set' = set
| otherwise = transitiveClosure (fun) set'
where
accum input set = insert (fun input) set
set' = union set (foldr (accum) [] set)
--
-- Example
--
replaceFirst :: Eq a => a -> a -> [a] -> [a]
replaceFirst x y [] = []
replaceFirst x y (c:cs)
| x == c = y:cs
| otherwise = c:(replaceFirst x y cs)
-- *TransitiveClosure> replaceFirst 'a' 'x' "Banana"
-- "Bxnana"
-- *TransitiveClosure> iterateToFixpoint (replaceFirst 'a' 'x') "Banana"
-- "Bxnxnx"
-- *TransitiveClosure> transitiveClosure (replaceFirst 'a' 'x') ["Banana"]
-- ["Banana","Bxnana","Bxnxna","Bxnxnx"]