mirror of
https://github.com/Jaxan/ons-hs.git
synced 2025-04-27 14:47:45 +02:00
56 lines
2.2 KiB
Haskell
56 lines
2.2 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
|
|
module Main where
|
|
|
|
import Nominal hiding (product)
|
|
import Support (Rat(..))
|
|
import OrbitList
|
|
import EquivariantMap (EquivariantMap, lookup, fromSet)
|
|
import EquivariantSet (fromOrbitList, toList)
|
|
|
|
import Prelude hiding (filter, null, elem, lookup, product, Word, map)
|
|
|
|
type Word a = [a]
|
|
type Alph a = OrbitList a
|
|
type Rows a = OrbitList (Word a)
|
|
type Columns a = OrbitList (Word a)
|
|
type Table a = EquivariantMap (Word a, Word a) Bool
|
|
|
|
unequalRows :: (Nominal a, Ord (Orbit a)) => Word a -> Word a -> Columns a -> Table a -> Bool
|
|
unequalRows s0 t0 suffs table =
|
|
False `elem` ( productWith (\(s, t) e -> lookup (s, e) table == lookup (t, e) table) (singleOrbit (s0, t0)) suffs )
|
|
|
|
|
|
equalRows :: (Nominal a, Ord (Orbit a)) => Word a -> Word a -> Columns a -> Table a -> Bool
|
|
equalRows s0 t0 suffs table = not (unequalRows s0 t0 suffs table)
|
|
|
|
closed :: (Nominal a, Ord (Orbit a)) => Word a -> Rows a -> Columns a -> Table a -> Bool
|
|
closed t prefs suffs table =
|
|
null (filter (\(t, s) -> unequalRows t s suffs table) (product (singleOrbit t) prefs))
|
|
|
|
nonClosedness :: (Nominal a, Ord (Orbit a)) => Rows a -> Rows a -> Columns a -> Table a -> Rows a
|
|
nonClosedness prefs prefsExt suffs table =
|
|
filter (\t -> not (closed t prefs suffs table)) prefsExt
|
|
|
|
inconsistencies :: (Nominal a, Ord a, Ord (Orbit a)) => Rows a -> Columns a -> Table a -> Alph a -> OrbitList (([a], [a]), (a, Word a))
|
|
inconsistencies prefs suffs table alph =
|
|
filter (\((s, t), (a, e)) -> lookup (s ++ [a], e) table /= lookup (t ++ [a], e) table) candidatesExt
|
|
where
|
|
candidates = filter (\(s, t) -> s < t && equalRows s t suffs table) (product prefs prefs)
|
|
candidatesExt = product candidates (product alph suffs)
|
|
|
|
|
|
-- Example to test
|
|
accept [Rat a, Rat b] = a == b
|
|
accept _ = False
|
|
|
|
main :: IO ()
|
|
main = do
|
|
let alph = rationals
|
|
prefs = singleOrbit [] `union` map (\r -> [r]) alph
|
|
prefsExt = productWith (\p a -> p ++ [a]) prefs alph
|
|
suffs = singleOrbit []
|
|
table = fromSet (\(a, b) -> accept (a ++ b)) . fromOrbitList $ product (prefs `union` prefsExt) (suffs)
|
|
print (toList . fromOrbitList $ (nonClosedness prefs prefsExt suffs table))
|
|
print (toList . fromOrbitList $ (inconsistencies prefs suffs table alph))
|
|
|