msakai / toysolver / 496

Committed 10 Nov 2024 11:05AM UTC coverage: 69.994% (-1.1%) from 71.113%

Build # 496

Build Type

push

github

Committed by

web-flow

Commit Message

Merge pull request #117 from msakai/update-coveralls-and-haddock

GitHub Actions: Update coveralls and haddock configuration

Run Details

9872 of 14104 relevant lines covered (69.99%)

0.7 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

54.35

/src/ToySolver/Data/OrdRel.hs

{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  ToySolver.Data.OrdRel
-- Copyright   :  (c) Masahiro Sakai 2011
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  non-portable
--
-- Ordering relations
--
-----------------------------------------------------------------------------
module ToySolver.Data.OrdRel
  (
  -- * Relational operators
    RelOp (..)
  , flipOp
  , negOp
  , showOp
  , evalOp

  -- * Relation
  , OrdRel (..)
  , fromOrdRel

  -- * DSL
  , IsEqRel (..)
  , IsOrdRel (..)
  ) where

import qualified Data.IntSet as IS

import ToySolver.Data.Boolean
import ToySolver.Data.IntVar

infix 4 .<., .<=., .>=., .>., .==., ./=.

-- ---------------------------------------------------------------------------

-- | relational operators
data RelOp = Lt | Le | Ge | Gt | Eql | NEq
    deriving (Show, Eq, Ord)


-- | flipping relational operator
--
-- @rel (flipOp op) a b@ is equivalent to @rel op b a@
flipOp :: RelOp -> RelOp
flipOp Le = Ge
flipOp Ge = Le
flipOp Lt = Gt
flipOp Gt = Lt
flipOp Eql = Eql
flipOp NEq = NEq

-- | negating relational operator
--
-- @rel (negOp op) a b@ is equivalent to @notB (rel op a b)@
negOp :: RelOp -> RelOp
negOp Lt = Ge
negOp Le = Gt
negOp Ge = Lt
negOp Gt = Le
negOp Eql = NEq
negOp NEq = Eql

-- | operator symbol
showOp :: RelOp -> String
showOp Lt = "<"
showOp Le = "<="
showOp Ge = ">="
showOp Gt = ">"
showOp Eql = "="
showOp NEq = "/="

-- | evaluate an operator into a comparision function
evalOp :: Ord a => RelOp -> a -> a -> Bool
evalOp Lt = (<)
evalOp Le = (<=)
evalOp Ge = (>=)
evalOp Gt = (>)
evalOp Eql = (==)
evalOp NEq = (/=)

-- ---------------------------------------------------------------------------

-- | type class for constructing relational formula
class IsEqRel e r | r -> e where
  (.==.) :: e -> e -> r
  (./=.) :: e -> e -> r

-- | type class for constructing relational formula
class IsEqRel e r => IsOrdRel e r | r -> e where
  (.<.), (.<=.), (.>.), (.>=.) :: e -> e -> r
  ordRel :: RelOp -> e -> e -> r

  a .<. b  = ordRel Lt a b
  a .<=. b = ordRel Le a b
  a .>. b  = ordRel Gt a b
  a .>=. b = ordRel Ge a b

  ordRel Lt a b  = a .<. b
  ordRel Gt a b  = a .>. b
  ordRel Le a b  = a .<=. b
  ordRel Ge a b  = a .>=. b
  ordRel Eql a b = a .==. b
  ordRel NEq a b = a ./=. b

  {-# MINIMAL ((.<.), (.<=.), (.>.), (.>=.)) | ordRel #-}

-- ---------------------------------------------------------------------------

-- | Atomic formula
data OrdRel e = OrdRel e RelOp e
    deriving (Show, Eq, Ord)

instance Complement (OrdRel c) where
  notB (OrdRel lhs op rhs) = OrdRel lhs (negOp op) rhs

instance IsEqRel e (OrdRel e) where
  (.==.) = ordRel Eql
  (./=.) = ordRel NEq

instance IsOrdRel e (OrdRel e) where
  ordRel op a b = OrdRel a op b

instance Variables e => Variables (OrdRel e) where
  vars (OrdRel a _ b) = vars a `IS.union` vars b

instance Functor OrdRel where
  fmap f (OrdRel a op b) = OrdRel (f a) op (f b)

fromOrdRel :: IsOrdRel e r => OrdRel e -> r
fromOrdRel (OrdRel a op b) = ordRel op a b

-- ---------------------------------------------------------------------------

instance (Eval m e a, Ord a) => Eval m (OrdRel e) Bool where
  eval m (OrdRel lhs op rhs) = evalOp op (eval m lhs) (eval m rhs)

1	{-# OPTIONS_HADDOCK show-extensions #-}
2	{-# LANGUAGE FlexibleInstances #-}
3	{-# LANGUAGE FunctionalDependencies #-}
4	{-# LANGUAGE MultiParamTypeClasses #-}
5	{-# LANGUAGE UndecidableInstances #-}
6	-----------------------------------------------------------------------------
7	-- \|
8	-- Module : ToySolver.Data.OrdRel
9	-- Copyright : (c) Masahiro Sakai 2011
10	-- License : BSD-style
11	--
12	-- Maintainer : masahiro.sakai@gmail.com
13	-- Stability : provisional
14	-- Portability : non-portable
15	--
16	-- Ordering relations
17	--
18	-----------------------------------------------------------------------------
19	module ToySolver.Data.OrdRel
20	(
21	-- * Relational operators
22	RelOp (..)
23	, flipOp
24	, negOp
25	, showOp
26	, evalOp
27
28	-- * Relation
29	, OrdRel (..)
30	, fromOrdRel
31
32	-- * DSL
33	, IsEqRel (..)
34	, IsOrdRel (..)
35	) where
36
37	import qualified Data.IntSet as IS
38
39	import ToySolver.Data.Boolean
40	import ToySolver.Data.IntVar
41
42	infix 4 .<., .<=., .>=., .>., .==., ./=.
43
44	-- ---------------------------------------------------------------------------
45
46	-- \| relational operators
47	data RelOp = Lt \| Le \| Ge \| Gt \| Eql \| NEq
48	deriving (Show, Eq, Ord)	×
49
50
51	-- \| flipping relational operator
52	--
53	-- @rel (flipOp op) a b@ is equivalent to @rel op b a@
54	flipOp :: RelOp -> RelOp
55	flipOp Le = Ge	1✔
56	flipOp Ge = Le	1✔
57	flipOp Lt = Gt	1✔
58	flipOp Gt = Lt	1✔
59	flipOp Eql = Eql	1✔
60	flipOp NEq = NEq	×
61
62	-- \| negating relational operator
63	--
64	-- @rel (negOp op) a b@ is equivalent to @notB (rel op a b)@
65	negOp :: RelOp -> RelOp
66	negOp Lt = Ge	1✔
67	negOp Le = Gt	×
68	negOp Ge = Lt	×
69	negOp Gt = Le	×
70	negOp Eql = NEq	1✔
71	negOp NEq = Eql	×
72
73	-- \| operator symbol
74	showOp :: RelOp -> String
75	showOp Lt = "<"	×
76	showOp Le = "<="	×
77	showOp Ge = ">="	×
78	showOp Gt = ">"	×
79	showOp Eql = "="	×
80	showOp NEq = "/="	×
81
82	-- \| evaluate an operator into a comparision function
83	evalOp :: Ord a => RelOp -> a -> a -> Bool
84	evalOp Lt = (<)	1✔
85	evalOp Le = (<=)	1✔
86	evalOp Ge = (>=)	1✔
87	evalOp Gt = (>)	1✔
88	evalOp Eql = (==)	1✔
89	evalOp NEq = (/=)	1✔
90
91	-- ---------------------------------------------------------------------------
92
93	-- \| type class for constructing relational formula
94	class IsEqRel e r \| r -> e where
95	(.==.) :: e -> e -> r
96	(./=.) :: e -> e -> r
97
98	-- \| type class for constructing relational formula
99	class IsEqRel e r => IsOrdRel e r \| r -> e where
100	(.<.), (.<=.), (.>.), (.>=.) :: e -> e -> r
101	ordRel :: RelOp -> e -> e -> r
102
103	a .<. b = ordRel Lt a b	1✔
104	a .<=. b = ordRel Le a b	1✔
105	a .>. b = ordRel Gt a b	1✔
106	a .>=. b = ordRel Ge a b	1✔
107
108	ordRel Lt a b = a .<. b	×
109	ordRel Gt a b = a .>. b	×
110	ordRel Le a b = a .<=. b	×
111	ordRel Ge a b = a .>=. b	×
112	ordRel Eql a b = a .==. b	×
113	ordRel NEq a b = a ./=. b	×
114
115	{-# MINIMAL ((.<.), (.<=.), (.>.), (.>=.)) \| ordRel #-}
116
117	-- ---------------------------------------------------------------------------
118
119	-- \| Atomic formula
120	data OrdRel e = OrdRel e RelOp e
121	deriving (Show, Eq, Ord)	×
122
123	instance Complement (OrdRel c) where
124	notB (OrdRel lhs op rhs) = OrdRel lhs (negOp op) rhs	1✔
125
126	instance IsEqRel e (OrdRel e) where
127	(.==.) = ordRel Eql	1✔
128	(./=.) = ordRel NEq	1✔
129
130	instance IsOrdRel e (OrdRel e) where	1✔
131	ordRel op a b = OrdRel a op b	1✔
132
133	instance Variables e => Variables (OrdRel e) where
134	vars (OrdRel a _ b) = vars a `IS.union` vars b	1✔
135
136	instance Functor OrdRel where	×
137	fmap f (OrdRel a op b) = OrdRel (f a) op (f b)	1✔
138
139	fromOrdRel :: IsOrdRel e r => OrdRel e -> r
140	fromOrdRel (OrdRel a op b) = ordRel op a b	×
141
142	-- ---------------------------------------------------------------------------
143
144	instance (Eval m e a, Ord a) => Eval m (OrdRel e) Bool where
145	eval m (OrdRel lhs op rhs) = evalOp op (eval m lhs) (eval m rhs)	1✔

msakai / toysolver / 496

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous