Fixed issue #166

AmpersandTarski · Feb 18, 2016 · 04a0d13 · 04a0d13 · sjcjoosten · Feb 18, 2016
1 parent 8a6fb4b
commit 04a0d13
Show file tree

Hide file tree

Showing 4 changed files with 6 additions and 47 deletions.
diff --git a/src/Database/Design/Ampersand.hs b/src/Database/Design/Ampersand.hs
@@ -53,7 +53,7 @@ module Database.Design.Ampersand
    , cfProof,dfProof,normPA
    , lookupCpt
    , showPrf
-   , notCpl, isCpl, isPos, isNeg, foldrMapExpression
+   , notCpl, isCpl, isPos, isNeg
       , (.==.), (.|-.), (./\.), (.\/.), (.-.), (./.), (.\.), (.<>.), (.:.), (.!.), (.*.)
    , deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc
    , exprUni2list, exprIsc2list, exprCps2list, exprRad2list, exprPrd2list
@@ -102,6 +102,6 @@ import Database.Design.Ampersand.FSpec
 import Database.Design.Ampersand.Input
 import Database.Design.Ampersand.Misc
 import Database.Design.Ampersand.Components
-import Database.Design.Ampersand.ADL1.Expression (isPos,isNeg,foldrMapExpression)
+import Database.Design.Ampersand.ADL1.Expression (isPos,isNeg)
 import Database.Design.Ampersand.FSpec.ToFSpec.NormalForms
 import Database.Design.Ampersand.ADL1.P2A_Converters
diff --git a/src/Database/Design/Ampersand/ADL1/Expression.hs b/src/Database/Design/Ampersand/ADL1/Expression.hs
@@ -1,7 +1,6 @@
 {-# LANGUAGE TypeSynonymInstances #-}
 module Database.Design.Ampersand.ADL1.Expression (
                        subst
-                      ,foldlMapExpression,foldrMapExpression
                       ,primitives,isMp1, isEEps
                       ,isPos,isNeg, deMorganERad, deMorganECps, deMorganEUni, deMorganEIsc, notCpl, isCpl
                       ,exprIsc2list, exprUni2list, exprCps2list, exprRad2list, exprPrd2list
@@ -40,31 +39,6 @@ subst (decl,expr) = subs
        subs e@EDcV{}     = e
        subs e@EMp1{}     = e
 
-foldlMapExpression :: (a -> r -> a) -> (Declaration->r) -> a -> Expression -> a
-foldlMapExpression f = foldrMapExpression f' where f' x y = f y x
-
-foldrMapExpression :: (r -> a -> a) -> (Declaration->r) -> a -> Expression -> a
-foldrMapExpression f g a (EEqu (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
-foldrMapExpression f g a (EInc (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
-foldrMapExpression f g a (EIsc (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
-foldrMapExpression f g a (EUni (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
-foldrMapExpression f g a (EDif (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
-foldrMapExpression f g a (ELrs (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
-foldrMapExpression f g a (ERrs (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
-foldrMapExpression f g a (EDia (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
-foldrMapExpression f g a (ECps (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
-foldrMapExpression f g a (ERad (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
-foldrMapExpression f g a (EPrd (l,r)) = foldrMapExpression f g (foldrMapExpression f g a l) r
-foldrMapExpression f g a (EKl0 e)     = foldrMapExpression f g a                         e
-foldrMapExpression f g a (EKl1 e)     = foldrMapExpression f g a                         e
-foldrMapExpression f g a (EFlp e)     = foldrMapExpression f g a                         e
-foldrMapExpression f g a (ECpl e)     = foldrMapExpression f g a                         e
-foldrMapExpression f g a (EBrk e)     = foldrMapExpression f g a                         e
-foldrMapExpression f g a (EDcD d)     = f (g d) a
-foldrMapExpression _ _ a  EDcI{}      = a
-foldrMapExpression _ _ a  EEps{}      = a
-foldrMapExpression _ _ a  EDcV{}      = a
-foldrMapExpression _ _ a  EMp1{}      = a
 
 primitives :: Expression -> [Expression]
 primitives expr =

diff --git a/src/Database/Design/Ampersand/ADL1/P2A_Converters.hs b/src/Database/Design/Ampersand/ADL1/P2A_Converters.hs
@@ -243,12 +243,7 @@ pCtx2aCtx _
                      , ctxrs = rules
                      , ctxds = map fst declsAndPops
                      , ctxpopus = nub (udpops
-                                     ++map snd declsAndPops
-                                     ++mp1Pops contextInfo rules
-                                     ++mp1Pops contextInfo pats
-                                     ++mp1Pops contextInfo identdefs
-                                     ++mp1Pops contextInfo viewdefs
-                                     ++mp1Pops contextInfo interfaces)
+                                     ++map snd declsAndPops)
                      , ctxcds = allConceptDefs
                      , ctxks = identdefs
                      , ctxrrules = allRoleRules

diff --git a/src/Database/Design/Ampersand/Classes/ConceptStructure.hs b/src/Database/Design/Ampersand/Classes/ConceptStructure.hs
@@ -5,7 +5,7 @@ import Database.Design.Ampersand.Core.AbstractSyntaxTree
 import Database.Design.Ampersand.Basics
 import Data.List
 import Data.Maybe
-import Database.Design.Ampersand.ADL1.Expression(primitives,isMp1,foldrMapExpression)
+import Database.Design.Ampersand.ADL1.Expression(primitives)
 import Database.Design.Ampersand.Classes.ViewPoint
 import Prelude hiding (Ordering(..))
 
@@ -27,17 +27,6 @@ class ConceptStructure a where
   primsMentionedIn = nub . concatMap primitives . expressionsIn
   expressionsIn :: a -> [Expression] -- ^ The set of all expressions within data structure a
 
-  -- | mp1Pops draws the population from singleton expressions.
-  mp1Pops :: ContextInfo -> a -> [Population]
-  mp1Pops ci struc = []
---   = [ ACptPopu{ popcpt = cpt (head cl)
---               , popas = map atm cl } 
---     | cl<-eqCl cpt ((filter isMp1.primsMentionedIn) struc)]
---     where cpt (EMp1 _ c)   = c
---           cpt _            = fatal 31 "cpt error"
---           atm (EMp1 val c) = safePSingleton2AAtomVal ci c val
---           atm _            = fatal 31 "atm error"
-
 prim2rel :: Expression -> Declaration
 prim2rel e
  = case e of
@@ -100,7 +89,8 @@ instance ConceptStructure Expression where
   concs (EEps i sgn) = nub (i:concs sgn)
   concs (EDcV   sgn) = concs sgn
   concs (EMp1 _ c  ) = [c]
-  concs e            = foldrMapExpression uni concs [] e
+  concs e            = trace ("concs ("++show e++") = ") $
+                       concs (primitives e)
   expressionsIn e = [e]
 
 instance ConceptStructure A_Concept where