1 2 -- ==========================================================-- 3 -- === Printer of abstract functions ===-- 4 -- === File: PrintResults.m ===-- 5 -- ==========================================================-- 6 7 module PrintResults where 8 import BaseDefs 9 import Utils 10 import MyUtils 11 import Inverse 12 import AbstractMisc 13 14 -- ==========================================================-- 15 -- 16 prLift :: PrDomain -> PrDomain 17 18 prLift d = newBottom:d 19 where 20 dElemLen = length (head d) 21 dBottomElem = minimum (concat d) - (1 :: Int) 22 newBottom = copy dElemLen dBottomElem 23 24 25 -- ==========================================================-- 26 -- 27 prCross :: PrDomain -> PrDomain -> PrDomain 28 29 prCross d1 d2 = [e1++e2 | e1 <- d1, e2 <- d2] 30 31 32 -- ==========================================================-- 33 -- 34 prCrossList :: [PrDomain] -> PrDomain 35 36 prCrossList [] = [[0]] -- ???????????? 37 prCrossList [d] = d 38 prCrossList (a:b:abs) = prCross a (prCrossList (b:abs)) 39 40 41 -- ==========================================================-- 42 -- 43 prAllPoints :: Domain -> [Char] 44 45 prAllPoints d 46 = "{" ++ interleave " " ((h.g.f) d) ++ "}" 47 where 48 -- f creates the numbered version of a domain 49 f Two = [ [(-1) :: Int], [0 :: Int] ] 50 f (Lift1 ds) = prLift (prCrossList (map f ds)) 51 f (Lift2 ds) = prLift (prLift (prCrossList (map f ds))) 52 53 -- g normalises the numbers in a domain so the lowest is zero 54 g d = map (map (mySubtract (minimum (concat d)))) d 55 56 -- h converts a domain of numbers into one of characters 57 h x = map (map k) (g x) 58 59 -- k turns a number into its ascii representation 60 k :: Int -> Char 61 k n = toEnum (n+48) 62 63 64 -- ==========================================================-- 65 -- 66 prWidth :: Domain -> Int 67 68 prWidth Two = 1 :: Int 69 prWidth (Lift1 ds) = sum (map prWidth ds) 70 prWidth (Lift2 ds) = sum (map prWidth ds) 71 72 73 -- ==========================================================-- 74 -- 75 prLiftsIn :: Domain -> Int 76 77 prLiftsIn Two = 2 :: Int 78 prLiftsIn (Lift1 ds) = 1 + maximum (map prLiftsIn ds) 79 prLiftsIn (Lift2 ds) = 2 + maximum (map prLiftsIn ds) 80 81 82 -- ==========================================================-- 83 -- 84 prSucc :: Int -> Int -> Int 85 86 prSucc n c = n + c 87 88 89 -- ==========================================================-- 90 -- 91 prRoute :: Domain -> Route -> [Char] 92 93 prRoute d r 94 = let k :: Int -> Char 95 k n = toEnum (n + 48) 96 in 97 map k (prRouteMain d r) 98 99 100 -- ==========================================================-- 101 -- 102 prRouteMain :: Domain -> Route -> [Int] 103 104 prRouteMain Two Zero 105 = [0 :: Int] 106 prRouteMain Two One 107 = [1 :: Int] 108 109 prRouteMain d@(Lift1 ds) Stop1 110 = copy (prWidth d) 0 111 prRouteMain d@(Lift1 ds) (Up1 rs) 112 = map (prSucc 1) (prRouteMain_cross ds rs) 113 114 prRouteMain d@(Lift2 ds) Stop2 115 = copy (prWidth d) 0 116 prRouteMain d@(Lift2 ds) Up2 117 = copy (prWidth d) 1 118 prRouteMain d@(Lift2 ds) (UpUp2 rs) 119 = map (prSucc 2) (prRouteMain_cross ds rs) 120 121 prRouteMain_cross ds rs 122 = concat fixedRoutes 123 where 124 unFixedRoutes 125 = myZipWith2 prRouteMain ds rs 126 compFactors 127 = map prLiftsIn ds 128 compFactMax 129 = maximum compFactors 130 compFactNorm 131 = map subCompFactMax compFactors 132 fixedRoutes 133 = map applyCompensationFactor 134 (myZip2 compFactNorm unFixedRoutes) 135 applyCompensationFactor (n, roote) 136 = map (prSucc n) roote 137 subCompFactMax :: Int -> Int 138 subCompFactMax nn 139 = compFactMax - nn 140 141 142 -- ==========================================================-- 143 -- 144 prPrintFunction :: Bool -> StaticComponent -> Naam -> Point -> [Char] 145 146 -- the normal case, for printing non-constant functions 147 prPrintFunction mi statics fName (fDomain@(Func dss dt), Rep rep) 148 | amIsaHOF (Func dss dt) || NoFormat `elem` utSCflags statics 149 = "\nFunction \"" ++ fName++ "\" has input domains:\n" 150 ++ layn (map show dss) ++ 151 " and output domain\n " ++ 152 show dt ++ "\n\nwith value:\n\n" ++ show rep ++ "\n\n" 153 154 | otherwise 155 = "\nFunction \"" ++ fName++ "\" has input domains:\n" ++ 156 numberedPrInDs ++ 157 " and output domain\n " ++ 158 prettyOutDomain ++ 159 "\n\n Output | Lower frontier" ++ 160 "\n --------+----------------\n" ++ 161 concat (map f ((reverse.sort.amAllRoutes) dt)) ++ "\n\n" 162 where 163 pseudoParams 164 = utSureLookup (utSCfreevars statics) 165 "prPrintFunction" fName ++ forever "" 166 forever x = x:forever x 167 168 inputDomains = dss 169 170 outputDomain = dt 171 172 prettyInDomains = map prAllPoints inputDomains 173 prettyOutDomain = prAllPoints outputDomain 174 175 numberedPrInDs = layn (map ff (zip pseudoParams prettyInDomains)) 176 ff ("", pid) = pid 177 ff (name, pid) = pid ++ " (free \"" ++ name ++ "\")" 178 179 f op = let ipl = inMinInverse mi fDomain (Rep rep) op 180 in (copy (8 - length outColText) ' ') ++ outColText ++ 181 " | " ++ (interleave " and " (map g ipl)) ++ "\n" 182 where 183 outColText = prRoute dt op 184 g (MkFrel rs) = interleave " " (myZipWith2 prRoute dss rs) 185 186 187 -- the exception case, for printing constants 188 prPrintFunction mi statics fName (ds, rs) 189 | amContainsFunctionSpace ds 190 = "\nFunction \"" ++ fName++ 191 "\" is a higher-order constant (yuck) in domain\n\n" 192 ++ show ds ++ 193 "\n\nof value\n\n" ++ show rs ++ "\n\n" 194 195 | otherwise 196 = "\nFunction \"" ++ fName++ "\" is a constant point " ++ 197 prRoute ds rs ++ " in domain \n " ++ 198 prAllPoints ds ++ "\n\n" 199 200 201 -- ==========================================================-- 202 -- === end PrintResults.m ===-- 203 -- ==========================================================--