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