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 -- ==========================================================--