1 -- LML original: Sandra Foubister, 1990 2 -- Haskell translation: Colin Runciman, May 1991 3 4 module Auxprogfuns( 5 nearx,neary, deline, orient, display, cs, 6 wwscale, wscale, wline, showoris) where 7 8 import List ( (\\) ) -- 1.3 9 10 import Mgrfuns 11 import Diff 12 import Drawfuns 13 import Geomfuns 14 import Layout 15 import Rational 16 17 concmap3 :: (a -> b -> c -> [d]) -> [a] -> [b] -> [c] -> [d] 18 concmap3 f (x:xs) (y:ys) (z:zs) = f x y z ++ concmap3 f xs ys zs 19 concmap3 f _ _ _ = [] 20 21 -- see the pic related definitions for where the numbers come from 22 23 --CR numeric literals here not acceptable - needs abstraction 24 display :: [(a, [[Int]])] -> [Char] 25 display slist = concmap3 place [624,624,624,624,724,724,724,724] 26 [676,776,876,976,676,776,876,976] 27 (map snd slist) 28 29 -- These codings are used for the eight pictures, 30 -- for the program state, 31 -- and for the postscript file 32 -- CR replaced multiclause defn by case 33 34 orient :: Int -> Int -> [[Int]] -> [[Int]] 35 orient m n = case n of 36 0 -> (\_ -> [[0,0,0,0]]) 37 1 -> (\x -> x) 38 2 -> rotatecw m 39 3 -> rotatecw m . rotatecw m 40 4 -> antirotate m 41 5 -> tbinvert m 42 6 -> tbinvert m . rotatecw m 43 7 -> lrinvert m 44 8 -> lrinvert m . rotatecw m 45 46 pixdist :: Int 47 pixdist = 10 48 49 --CR removed old 'rmin2' definition - now use rmin from Rational module 50 51 between :: Int -> Int -> Int -> Bool 52 between n1 n2 n = (n1 <= n && n2 >= n) || (n1 >= n && n2 <= n) 53 54 --CR now uses Rational's rmin instead of old rmin2 55 --CR k1 redefined to avoid explicit use of norm 56 online :: [Int] -> Int -> Int -> Bool 57 online [x0,y0,x1,y1] xp yp = 58 if y0 == y1 then between x0 x1 xp && abs (y0 - yp) < pixdist 59 else if x0 == x1 then between y0 y1 yp && abs (x0 - xp) < pixdist 60 else b2 <= a2 + c2 && c2 <= a2 + b2 && intval (rmin dx dy) < pixdist 61 where 62 k1 = rdiv (torat (x0 - x1)) (torat (y0 - y1)) 63 k0 = rsub (torat x0) (rmul k1 (torat y0)) 64 xp' = radd k0 (rmul k1 (torat yp)) 65 yp' = rdiv (rsub (torat xp) k0) k1 66 a2 = square (diff x0 x1) + square (diff y0 y1) 67 b2 = square (diff x1 xp) + square (diff y1 yp) 68 c2 = square (diff x0 xp) + square (diff y0 yp) 69 dx = rabs (rsub (torat xp) xp') 70 dy = rabs (rsub (torat yp) yp') 71 72 --CR renamed firstline as thisline, firstcircs as thesecircs 73 --CR note allowance for argument order bug using \\ instead of difference 74 deline :: [([Int],[Int])] -> [Int] -> ([Char], [([Int],[Int])]) 75 deline ls [px,py] = 76 deline' ls 77 where 78 deline' [] = ("",ls) 79 deline' (pl:pls) = 80 if online thisline px py then 81 (undraw thisline ++ (undo . wline) thisline ++ decircs, remove1 ls pl) 82 else deline' pls 83 where 84 (thisline, thesecircs) = pl 85 restcircs = listremove1 (concat (map snd ls)) thesecircs 86 decircs = (concat . map decirc) (restcircs \\ thesecircs) 87 88 --CR remove1 xs y is xs with 1st occurrence (if any) of y removed 89 remove1 :: (Eq a) => [a] -> a -> [a] 90 remove1 (l:ls) i = if i==l then ls else l : remove1 ls i 91 remove1 [] i = [] 92 93 --CR replaced explicit recursion with foldl application 94 listremove1 :: (Eq a) => [a] -> [a] -> [a] 95 listremove1 = foldl remove1 96 97 -- functions to do with the drawing of lines and marking of circles 98 -- in the design phase 99 100 -- as the x and y lists for the design area are the same, the function 101 -- onedge can be defined without specifying onedgex and onedgey 102 103 onedge :: Int -> Bool 104 onedge n = n == dpxyorig || n == dpxyorig + (dpxynum -1) * dpxygap 105 106 -- similarly the method of finding the nearest x or y points 107 -- on the grid are equivalent 108 109 nearest :: Int -> Int 110 nearest n = if n - n1 < n2 - n then n1 else n2 111 where 112 n1 = dpxyorig + ((n - dpxyorig) `div` dpxygap) * dpxygap 113 n2 = n1 + dpxygap 114 115 -- but the cursor is not symmetrical in its deficiencies, so we have: 116 117 nearx, neary :: Int -> Int 118 nearx x = nearest (x - 4) 119 neary y = nearest (y - 5) 120 121 -- numassoc is to give points on the edge an associated number 122 123 numassoc :: Int -> Int 124 numassoc n = if n1 <= 9 then n1 else 18 - n1 125 where 126 n1 = (n - dpxyorig) `div` dpxygap 127 128 -- circ6 for drawing the little circles 129 130 circ6 :: Int -> Int -> [Char] 131 circ6 x y = circle [x,y,6] 132 133 -- circsym for identifying symmetrically placed dots and 134 -- drawing circles round them. It assumes that the x and y 135 -- have been adjusted to allow for the dicky cursor. 136 137 circsym :: Int -> Int -> ([Char], [Int]) 138 circsym xn yn = if onedge xn then (symcircs yn,[numassoc yn]) 139 else if onedge yn then (symcircs xn,[numassoc xn]) 140 else ("",[]) 141 142 --CR explanation of numeric literals? 143 sympat :: Int -> [Int] 144 sympat n = [n, 400-n, 380, 380, 400-n, n, 20, 20] 145 146 symcircs :: Int -> [Char] 147 symcircs n = concat (zipWith circ6 (sympat n) (reverse (sympat n))) 148 149 -- assumes the coordinates have already been corrected to allow 150 -- for the deficiencies of the cursor, and to fit into the grid 151 cs :: [Int] -> ([Char], [Int]) 152 cs [x0,y0,x1,y1] = 153 (line [x0,y0,x1,y1] ++ circles0 ++ circles1, ids0++ids1) 154 where 155 (circles0,ids0) = circsym x0 y0 156 (circles1,ids1) = circsym x1 y1 157 158 decirc :: Int -> [Char] 159 decirc n = (undo . symcircs) (n * dpxygap + dpxyorig) 160 161 -- wscale for the lines in the wee square 162 wscale :: Int -> Int 163 wscale n = (n - dpxyorig) `div` 5 164 165 -- wwscale for the lines in postscript 166 wwscale :: Int -> Int 167 wwscale n = (n - dpxyorig) `div` 10 168 169 wline :: [Int] -> [Char] 170 wline = line . 171 mapx (\x -> x + picxorig) . 172 mapy (\y -> y + picyorig) . 173 map wscale 174 175 showoris :: [[Int]] -> Int -> [Char] 176 showoris coords n = place x y (((orient xymax) n . map (map wscale)) coords) 177 where 178 [x,y,w,h] = picbox n 179 180 181