Hugs-98-March-99 (started by ..hugs -98 +o -h2200K ...)
gives the wrong result (OSet False, OSet True)
for the enclosed program.
Since upAu is obtained as substitution a <-- u into upA,
s should equal s' in the result. And it does not.
There are overlapping instances ..=> Set (Residue a),
..=> Set (Residue (UPol a))
- see the lines with `**'.
Commenting out any of them hides the bug.
The impression is that Hugs chooses the first instance for s and
the second for s'.
The initial program was 70 times larger.
Probably, it is not hard to reduce it further. Maybe, many classes
can be removed. I would not do it myself because the thing may depend
on the memory settig, and the effect may disappear on other machine.
I also have changed in the Hugs source the maximal constants for
the Program code size, and Control stack, though do not expect, this
is essential for the result.
------------------
Sergey Mechveliani
[EMAIL PROTECTED]
----------------------------------------------------------------------
module Bug (bug)
where
bug = let r1 = SR 1 5
dK = upRing r1 emptyFM
unT = UPol [] r1 "t" dK
dT = upRing unT emptyFM
u = Rse unT unT dT
upSg a = case baseSet a emptyFM of
(d',_) -> fst (baseAddSemigroup a d')
upA a = case upSg a of t -> fst (baseAddGroup a t)
upAu = case upSg u of t -> fst (baseAddGroup u t)
Just (D1Set s ) = lookupFM (upA u) Set
Just (D1Set s') = lookupFM upAu Set
in
(s,s')
-- PRELUDE ***********************************************************
data FM a b = FM [(a,b)]
emptyFM :: FM key elt
emptyFM = FM []
lookupFM :: (Ord key ) => FM key elt -> key -> Maybe elt
lookupFM (FM ps) k = lookup k ps
addToFM :: (Ord key) => FM key elt -> key -> elt -> FM key elt
addToFM (FM ps) k a =
case span ((/= k).fst) ps
of
(ps', (_,_):ps'') -> FM (ps'++(k,a):ps'')
_ -> FM ((k,a):ps)
---------------------------------------------------------------------
class (Eq a,Show a,Read a) => Set a
where
baseSet :: a -> Domains1 a -> (Domains1 a, OSet a)
---------------------------------------------------------------------
data OSet a = OSet Bool deriving(Show)
data Subsemigroup a = Subsemigroup Bool deriving(Show)
data Subgroup a = Subgroup Bool deriving(Show)
data Subring a = Subring Bool deriving(Show)
type Domains1 a = FM CategoryName (Domain1 a)
data CategoryName =
Set | AddSemigroup | AddGroup | MulSemigroup | MulGroup | Ring
deriving(Eq,Ord,Enum,Show)
data Domain1 a = D1Set (OSet a) | D1Smg (Subsemigroup a)
| D1Group (Subgroup a) | D1Ring (Subring a)
deriving(Show)
instance Read a => Read (Domain1 a)
type Factorization a = [(a,Int)]
class (Set a) => AddSemigroup a
where
baseAddSemigroup :: a -> Domains1 a -> (Domains1 a,Subsemigroup a)
upAddSemigroup :: (AddSemigroup a) => a -> Domains1 a -> Domains1 a
upAddSemigroup a =
fst .(baseAddSemigroup a) .fst .(baseSet a)
class (AddSemigroup a) => AddMonoid a
class AddMonoid a => AddGroup a
where
baseAddGroup :: a -> Domains1 a -> (Domains1 a, Subgroup a)
class (Set a) => MulSemigroup a
where
baseMulSemigroup :: a-> Domains1 a-> (Domains1 a,Subsemigroup a)
class MulSemigroup a => MulMonoid a
class MulMonoid a => MulGroup a
where
baseMulGroup :: a -> Domains1 a -> (Domains1 a, Subgroup a)
upAddGroup :: AddGroup a => a -> Domains1 a -> Domains1 a
upMulGroup :: MulGroup a => a -> Domains1 a -> Domains1 a
upMulSemigroup :: MulSemigroup a => a -> Domains1 a -> Domains1 a
upAddGroup a = fst .(baseAddGroup a) .(upAddSemigroup a)
upMulGroup a = fst .(baseMulGroup a) .(upMulSemigroup a)
upMulSemigroup a = fst .(baseMulSemigroup a) .fst .(baseSet a)
--------------------------------------------------------------------
instance Set Int where baseSet _ d = (d, OSet True)
instance AddSemigroup Int
instance AddMonoid Int
instance AddGroup Int
intDom :: (IntLike a) => Domains1 a
intDom = upRing (0::IntLike a=>a) emptyFM
instance MulSemigroup Int
instance MulMonoid Int
instance Ring Int
instance CommutativeRing Int
instance Fractional Int
instance GCDRing Int
instance LinSolvRing Int
instance EuclideanRing Int
instance IntLike Int
-------------------------------------------------------------------
class (AddGroup a,MulSemigroup a,Num a,Fractional a) => Ring a
where
baseRing :: a -> Domains1 a -> (Domains1 a, Subring a)
class (Ring a) => CommutativeRing a
class (CommutativeRing a,MulMonoid a) => GCDRing a
class (CommutativeRing a,MulMonoid a) => LinSolvRing a
class (GCDRing a,LinSolvRing a) => EuclideanRing a
class (EuclideanRing a) => Field a
class (EuclideanRing a,Integral a) => IntLike a
--------------------------------------------------------------------
type ADomDom a = a -> Domains1 a -> Domains1 a
upRing :: Ring a => ADomDom a
upRing a = fst .(baseRing a).fst .(baseMulSemigroup a).(upAddGroup a)
---------------------------------------------------------------------
type UMon a = (a, Int)
data UPol a = UPol [UMon a] a String (Domains1 a)
instance (Eq a) => Eq (UPol a)
instance (Ring a) => Show (UPol a)
instance (Read a) => Read (UPol a)
instance (CommutativeRing a) => Set (UPol a)
instance (CommutativeRing a) => AddSemigroup (UPol a)
where
baseAddSemigroup _ d = (d, Subsemigroup True)
instance (CommutativeRing a) => AddMonoid (UPol a)
instance (CommutativeRing a) => AddGroup (UPol a)
instance (CommutativeRing a) => MulSemigroup (UPol a)
instance (CommutativeRing a,MulMonoid a) => MulMonoid (UPol a)
instance (CommutativeRing a) => Num (UPol a)
instance (CommutativeRing a) => Fractional (UPol a)
instance (CommutativeRing a) => Ring (UPol a)
instance (CommutativeRing a) => CommutativeRing (UPol a)
instance (EuclideanRing a) => LinSolvRing (UPol a)
instance (Field a) => EuclideanRing (UPol a)
instance (GCDRing a) => GCDRing (UPol a)
-- ***************
instance (Field a) => Set (ResidueE (UPol a))
where
baseSet _ d = (addToFM d Set (D1Set o), o) where o = OSet True
-- ***************
instance (Field a) => AddSemigroup (ResidueE (UPol a))
where
baseAddSemigroup _ d = (d,Subsemigroup True)
data SmallResidue = SR Int Int
instance Read SmallResidue
instance Show SmallResidue
instance Eq SmallResidue
class Residue r where resRepr :: r a -> a
instance (Residue r,Show a) => Show (r a)
instance (Residue r,Eq a ) => Eq (r a)
data ResidueE a = Rse a a (Domains1 a)
instance Read (ResidueE a)
instance Residue ResidueE
instance (Show a) => Show (ResidueE a)
-- **********************
instance (EuclideanRing a) => Set (ResidueE a)
where
baseSet r d = (addToFM d Set (D1Set o), o) where o = OSet False
-- **********************
instance (EuclideanRing a) => AddSemigroup (ResidueE a)
where
baseAddSemigroup r d = (d, Subsemigroup True) -- **
instance (EuclideanRing a) => AddMonoid (ResidueE a)
instance (EuclideanRing a) => AddGroup (ResidueE a)
where
baseAddGroup r d = (d, Subgroup True) -- **
instance (EuclideanRing a) => MulSemigroup (ResidueE a)
instance (EuclideanRing a) => MulMonoid (ResidueE a)
instance (EuclideanRing a) => Num (ResidueE a)
instance (EuclideanRing a) => Fractional (ResidueE a)
instance (EuclideanRing a) => Ring (ResidueE a)
instance (EuclideanRing a) => CommutativeRing (ResidueE a)
instance (EuclideanRing a) => LinSolvRing (ResidueE a)
instance (EuclideanRing a) => GCDRing (ResidueE a)
instance (EuclideanRing a) => EuclideanRing (ResidueE a)
instance (EuclideanRing a) => Field (ResidueE a)
--------------------------------------------------------------------
instance Set SmallResidue
instance AddSemigroup SmallResidue
instance AddMonoid SmallResidue
instance AddGroup SmallResidue
instance MulSemigroup SmallResidue
instance MulMonoid SmallResidue
instance Num SmallResidue
instance Fractional SmallResidue
instance Ring SmallResidue
instance CommutativeRing SmallResidue
instance GCDRing SmallResidue
instance LinSolvRing SmallResidue
instance EuclideanRing SmallResidue
instance Field SmallResidue
