1         
    2 -- ==========================================================--
    3 -- === Domain expressions.                                ===--
    4 -- ===                                      DomainExpr.hs ===--
    5 -- ==========================================================--
    6 
    7 module DomainExpr where
    8 import BaseDefs
    9 import Utils
   10 import MyUtils
   11 
   12 -- ==========================================================--
   13 --
   14 dxApplyDSubst_2 :: DExpr -> Domain
   15 
   16 dxApplyDSubst_2 DXTwo               = Two
   17 dxApplyDSubst_2 (DXVar _)           = Two
   18 dxApplyDSubst_2 (DXLift1 [])        = Two  -- *** kludge *** --
   19 dxApplyDSubst_2 (DXLift1 dxs)       = Lift1 (map dxApplyDSubst_2 dxs)
   20 dxApplyDSubst_2 (DXLift2 [])        = Lift1 [Two]
   21                                       -- ** MEGA HACK ** --
   22                                       -- panic "dxApplyDSubst_2"
   23 dxApplyDSubst_2 (DXLift2 dxs)       = Lift2 (map dxApplyDSubst_2 dxs)
   24 dxApplyDSubst_2 (DXFunc dxs dxt)    = Func (map dxApplyDSubst_2 dxs)
   25                                            (dxApplyDSubst_2 dxt)
   26 
   27 
   28 -- ==========================================================--
   29 --
   30 dxApplyDSubst :: DSubst -> DExpr -> Domain
   31 
   32 dxApplyDSubst rho DXTwo = Two
   33 dxApplyDSubst rho (DXVar alpha)      = utSureLookup rho "dxApplySubst" alpha
   34 dxApplyDSubst rho (DXLift1 [])       = Two  -- *** kludge *** --
   35 dxApplyDSubst rho (DXLift1 dxs)      = Lift1 (map (dxApplyDSubst rho) dxs)
   36 dxApplyDSubst rho (DXLift2 [])       = Lift1 [Two]
   37                                        -- ** MEGA HACK ** --
   38                                        -- panic "dxApplyDSubst"
   39 dxApplyDSubst rho (DXLift2 dxs)      = Lift2 (map (dxApplyDSubst rho) dxs)
   40 dxApplyDSubst rho (DXFunc dxs dxt)   = Func (map (dxApplyDSubst rho) dxs)
   41                                             (dxApplyDSubst rho dxt)
   42 
   43 
   44 -- ==========================================================--
   45 --
   46 dxNormaliseDExpr :: DExpr -> DExpr
   47 
   48 dxNormaliseDExpr (DXFunc dss (DXFunc dss2 dt))
   49    = dxNormaliseDExpr (DXFunc (dss++dss2) dt)
   50 dxNormaliseDExpr (DXFunc dss dt)
   51    = DXFunc (map dxNormaliseDExpr dss) (dxNormaliseDExpr dt)
   52 
   53 dxNormaliseDExpr DXTwo           = DXTwo
   54 dxNormaliseDExpr (DXLift1 dxs)   = DXLift1 (map dxNormaliseDExpr dxs)
   55 dxNormaliseDExpr (DXLift2 dxs)   = DXLift2 (map dxNormaliseDExpr dxs)
   56 dxNormaliseDExpr (DXVar v)       = DXVar v
   57 
   58 
   59 -- ==========================================================--
   60 --
   61 dxContainsFnSpace :: DExpr -> Bool
   62 
   63 dxContainsFnSpace DXTwo           = False
   64 dxContainsFnSpace (DXLift1 dxs)   = myAny dxContainsFnSpace dxs
   65 dxContainsFnSpace (DXLift2 dxs)   = myAny dxContainsFnSpace dxs
   66 dxContainsFnSpace (DXFunc _ _)    = True
   67 dxContainsFnSpace (DXVar _)       = False
   68 
   69 
   70 -- ==========================================================--
   71 --
   72 dxContainsSubsidiaryFnSpace :: DExpr -> Bool
   73 
   74 dxContainsSubsidiaryFnSpace DXTwo 
   75    = False
   76 
   77 dxContainsSubsidiaryFnSpace (DXLift1 dxs) 
   78    = myAny dxContainsFnSpace dxs
   79 
   80 dxContainsSubsidiaryFnSpace (DXLift2 dxs) 
   81    = myAny dxContainsFnSpace dxs
   82 
   83 dxContainsSubsidiaryFnSpace (DXFunc dxss dxt)
   84    = myAny dxContainsFnSpace dxss || dxContainsFnSpace dxt
   85 
   86 dxContainsSubsidiaryFnSpace (DXVar _)
   87    = False
   88 
   89 
   90 -- ==========================================================--
   91 --        big       small
   92 dxDiff :: Domain -> Domain -> (DExpr, DSubst)
   93 
   94 dxDiff db ds
   95    = case
   96         doStatefulOp2 dxDiff_aux (fromEnum 'a', []) ds db
   97      of
   98         (dexpr, (num, dsubst)) -> (dexpr, dsubst)
   99 
  100 
  101 dxDiff_aux Two Two
  102    = returnS DXTwo
  103 
  104 dxDiff_aux Two not_two
  105    = fetchS                                  `thenS`  ( \ (n, sub) ->
  106      assignS (n+1, ([toEnum n], not_two):sub)   `thenS`  ( \ () ->
  107      returnS (DXVar [toEnum n])
  108      ))
  109 
  110 dxDiff_aux (Lift1 ds1) (Lift1 ds2)
  111    = dxDiff_list ds1 ds2              `thenS` ( \new_ds1_ds2 ->
  112      returnS (DXLift1 new_ds1_ds2)
  113      )
  114 
  115 dxDiff_aux (Lift2 ds1) (Lift2 ds2)
  116    = dxDiff_list ds1 ds2              `thenS` ( \new_ds1_ds2 ->
  117      returnS (DXLift2 new_ds1_ds2)
  118      )
  119 
  120 dxDiff_aux (Func dss1 dt1) (Func dss2 dt2)
  121    = dxDiff_list dss1 dss2            `thenS` ( \new_dss1_dss2 ->
  122      dxDiff_aux dt1 dt2               `thenS` ( \new_dt1_dt2 ->
  123      returnS (DXFunc new_dss1_dss2 new_dt1_dt2)
  124      ))
  125 
  126 dxDiff_aux other1 other2
  127    = panic "dxDiff_aux"
  128 
  129 
  130 dxDiff_list [] []
  131    = returnS []
  132 
  133 dxDiff_list (a:as) (b:bs)
  134    = dxDiff_aux a b                   `thenS`  ( \new_a_b ->
  135      dxDiff_list as bs                `thenS`  ( \new_as_bs ->
  136      returnS (new_a_b : new_as_bs)  
  137      ))
  138 
  139 dxDiff_list other1 other2
  140    = panic "dxDiff_list: unequal lists"
  141 
  142 
  143 -- ==========================================================--
  144 -- === end                                  DomainExpr.hs ===--
  145 -- ==========================================================--