1 -- LML original: Sandra Foubister, 1990 2 -- Haskell translation: Colin Runciman, May 1991 3 4 module Progfuns (tileprompt, tilequit, tiletrans, potatotile, State) where 5 6 import Mgrfuns 7 import Drawfuns 8 import Geomfuns 9 import Psfuns 10 import Interstate 11 import Auxprogfuns 12 import Layout 13 import Tilefuns 14 import Help 15 16 tileprompt :: a -> [Char] 17 tileprompt _ = "" 18 19 tilequit :: a -> [[Char]] -> Bool 20 tilequit _ (('q':_):_) = True 21 tilequit _ [] = True 22 tilequit _ _ = False 23 24 type State = ([([Int],[Int])], Int, [((Int,Int),Int)]) --CR needs abstraction! 25 type Trans = State -> [[Char]] -> ([Char], State, [[Char]]) 26 27 tiletrans :: Trans 28 29 tiletrans (dlist,sel,tilist) (('m':'s':'a':' ':rest):inpt) = 30 if intsave x y then doo tsave 31 else if intclear x y then doo tclear 32 else if intget x y then doo tget 33 else if intile4 x y then doo t4' 34 else if inquit x y then doo q 35 else if inbigtile x y then doo delsq 36 else if intoalter x y then doo tofiddle' 37 else if intotile x y then doo totile' 38 else if intodraw x y then doo todesign' 39 else if inpicarea x y then doo sel' 40 else if inhelp x y then doo tohelp' 41 else tiletrans (dlist,sel,tilist) inpt 42 where 43 [x,y] = stoil rest 44 doo fun = fun rest (dlist,sel,tilist) inpt 45 46 tiletrans (dlist,sel,tilist) (('m':'s':'b':' ':rest):inpt) = 47 if inbigtile x y then inv' rest (dlist,sel,tilist) inpt 48 else tiletrans (dlist,sel,tilist) (('m':'s':'a':' ':rest):inpt) 49 where 50 [x,y] = stoil rest 51 52 tiletrans (dlist,sel,tilist) (('m':'s':'c':' ':rest):inpt) = 53 if indesign x y then doo rl 54 else if indsave x y then doo dsave 55 else if indclear x y then doo dclear 56 else if indget x y then doo dget 57 else tiletrans (dlist,sel,tilist) (('m':'s':'a':' ':rest):inpt) 58 where 59 [x,y] = stoil rest 60 doo fun = fun rest (dlist,sel,tilist) inpt 61 62 tiletrans state (('m':'s':'d':' ':rest):inpt) = 63 (inithelp ++ out,state,inpt) 64 where 65 [x,y] = stoil rest 66 cf str = clear ++ str 67 out = if intodraw x y then cf helpdraw 68 else if intotile x y then cf helptile 69 else if intoalter x y then cf helpalter 70 else if intsave x y then cf helptsave 71 else if intclear x y then cf helptclear 72 else if intget x y then cf helptget 73 else if intile4 x y then cf helpt4 74 else if inquit x y then cf helpquit 75 else if inbigtile x y then cf helpbt 76 else if inpicarea x y then cf helppic 77 else if indesign x y then cf helpdesign 78 else if indsave x y then cf helpdsave 79 else if indclear x y then cf helpdclear 80 else if indget x y then cf helpdget 81 else if inhelp x y then cf inithelp 82 else cf errmes 83 84 tiletrans (dlist,sel,tilist) (('c':'s':' ':rest):inpt) = 85 if indgrid nstoilrest then 86 (linecircs ++ wnstoilrest,(newele:dlist,sel,tilist),inpt) 87 else 88 ("",(dlist,sel,tilist),inpt) 89 where 90 nearline [x0,y0,x1,y1] = [nearx x0, neary y0, nearx x1, neary y1] 91 nstoilrest = nearline (stoil rest) 92 wnstoilrest = wline nstoilrest 93 cssr = cs nstoilrest 94 newele = (nstoilrest,snd cssr) 95 linecircs = fst cssr 96 97 98 tiletrans (dlist,sel,tilist) (('r':'o':'t':' ':rest):inpt) = 99 if lsrest == [0,0] then 100 ("",(dlist,sel,tilist),inpt) 101 else 102 ( undo (put lsrest (orient xymax oldas wcoords)) ++ 103 put lsrest (orient xymax (rot oldas) wcoords) 104 , (dlist,sel,newtilist) 105 , inpt ) 106 where 107 stoilrest = stoil rest 108 wcoords = map (map wscale) (map fst dlist) 109 oldas = assoc (sqid stoilrest) tilist 110 newtilist = newas (sqid stoilrest) (rot oldas) tilist 111 lsrest = btlocate stoilrest 112 113 tiletrans (dlist,sel,tilist) (('p':'u':'t':' ':rest):inpt) = 114 if lsrest == [0,0] then 115 ("",(dlist,sel,tilist),inpt) 116 else 117 ( undo (put lsrest (orient xymax oldas wcoords)) ++ 118 put lsrest (orient xymax sel wcoords) 119 , (dlist,sel,newtilist) 120 , inpt ) 121 where 122 stoilrest = stoil rest 123 newtilist = newas (sqid stoilrest) sel tilist 124 lsrest = btlocate stoilrest 125 coords = map fst dlist 126 oldas = assoc (sqid stoilrest) tilist 127 wcoords = map (map wscale) coords 128 129 tiletrans state ("":inpt) = (helpend ++ todesign,state,inpt) 130 131 tiletrans state (_:inpt)= ("",state,inpt) 132 133 todesign', totile', tofiddle', tohelp' :: [Char] -> Trans 134 135 todesign' _ (dlist,sel,tilist) inpt = 136 ( cleara picarea ++ 137 picgrid ++ 138 cleara tilearea ++ 139 tpgrid ++ 140 showoris (map fst dlist) 1 ++ 141 todesign 142 , (dlist,sel,tilist) 143 , inpt ) 144 145 totile' _ (dlist,sel,tilist) inpt = 146 ( concat (map (showoris coords) [1..8]) ++ totile 147 , (dlist,sel,tilist) 148 , inpt) 149 where 150 coords = map fst dlist 151 152 tofiddle' _ (dlist,sel,tilist) inpt = (tofiddle,(dlist,sel,tilist),inpt) 153 154 tohelp' _ (dlist,sel,tilist) inpt = (tohelp,(dlist,sel,tilist),inpt) 155 156 rl, dsave, dclear, dget :: [Char] -> Trans 157 158 rl rest (dlist,sel,tilist) inpt = 159 (out,(newdlist,sel,tilist),inpt) 160 where 161 (out,newdlist) = deline dlist (stoil rest) 162 163 dsave _ state inpt = ("", state, inpt) --CR: dsave does nothing, for now 164 -- dsave _ (dlist,sel,tilist) inpt = 165 -- (out,(dlist,sel,tilist),t) 166 -- where 167 -- (h:t) = inpt 168 -- out = menumark "dsave" ++ 169 -- prompt ++ 170 -- tofile h ++ 171 -- totext (map fst dlist) ++ 172 -- "TOSTDOUT" ++ 173 -- clearit ++ 174 -- unmenumark "dsave" 175 176 dclear rest (dlist,sel,tilist) inpt = 177 ( menumark "dclear" ++ newdraw ++ unmark sel ++ unmenumark "dclear" 178 , ([],1,initalist) 179 , inpt ) 180 181 182 dget _ state inpt = ("", state, inpt) --CR: dget does nothing, for now 183 -- dget _ (dlist,sel,tilist) inpt = 184 -- ( menumark "dget" ++ prompt ++ out ++ unmenumark "dget" 185 -- , (newd,news,newt) 186 -- , i ) 187 -- where 188 -- (h:t) = inpt 189 -- conddraw = if dlist == [] then "" else newdraw 190 -- (out,(newd,news,newt),i) = 191 -- case openfile h of 192 -- No emsg -> ( emsg ++ "\n" ++ delay 1000 ++ clearit 193 -- , (dlist,sel,tilist) 194 -- , t ) 195 -- Yes file -> ( clearit ++ conddraw ++ out' 196 -- , s 197 -- , inp ) 198 -- where 199 -- (out',s,inp) = 200 -- tiletrans ([],sel,tilist) (lines file ++ t)) 201 202 sel', delsq, inv' :: [Char] -> Trans 203 204 sel' rest (dlist,sel,slist) inpt = 205 (unmark sel ++ mark newsel, (dlist,newsel,slist), inpt) 206 where 207 new = inbox (stoil rest) 208 newsel = if new == 0 then sel else new 209 210 delsq rest (dlist,sel,tilist) inpt = 211 ( undo (put lsrest (orient xymax oldas wcoords)) 212 , (dlist,sel,newtilist) 213 , inpt ) 214 where 215 wcoords = map (map wscale) (map fst dlist) 216 stoilrest = stoil rest 217 oldas = assoc (sqid stoilrest) tilist 218 lsrest = btlocate stoilrest 219 newtilist = newas (sqid stoilrest) 0 tilist 220 221 inv' rest (dlist,sel,tilist) inpt = 222 if lsrest == [0,0] then 223 ("",(dlist,sel,tilist),inpt) 224 else 225 ( undo (put lsrest (orient xymax oldas wcoords)) ++ 226 put lsrest (orient xymax (inv oldas) wcoords) 227 , (dlist,sel,newtilist) 228 , inpt ) 229 where 230 stoilrest = stoil rest 231 wcoords = map (map wscale) (map fst dlist) 232 oldas = assoc (sqid stoilrest) tilist 233 newtilist = newas (sqid stoilrest) (inv oldas) tilist 234 lsrest = btlocate stoilrest 235 236 tclear, tsave, tget, t4' :: [Char] -> Trans 237 238 tclear _ (dlist,sel,tilist) inpt = 239 ( menumark "tclear" ++ 240 cleara tilearea ++ 241 tpgrid ++ 242 totile ++ 243 unmenumark "tclear" 244 , (dlist,sel,initalist) 245 , inpt ) 246 247 tsave _ state inpt = ("", state, inpt) --CR: tsave does nothing, for now 248 -- tsave _ (dlist,sel,tilist) inpt = 249 -- ( menumark "tsave" ++ 250 -- prompt ++ 251 -- tofile h ++ 252 -- pos8head (tops dlist) ++ 253 -- introline ++ 254 -- concat . (map lf) ((reverse . ineights) (map (turn . snd) tilist)) ++ 255 -- "\nshowpage\n" ++ 256 -- tofile (h ++ ".pat") ++ 257 -- (tpatformat . ineights . map snd) tilist ++ 258 -- "TOSTDOUT" ++ 259 -- clearit ++ 260 -- unmenumark "tsave") 261 -- , (dlist,sel,tilist) 262 -- , t ) 263 -- where 264 -- (h:t) = inpt 265 -- tops = (map (map wwscale)) . (map fst) 266 267 tget _ state inpt = ("", state, inpt) --CR: tget does nothing, for now 268 -- tget rest (dlist,sel,tilist) inpt = 269 -- (out,(dlist,sel,(snd infromfile)),i) 270 -- where 271 -- (h:i) = inpt 272 -- wcoords = map (map wscale) (map fst dlist) 273 -- patfile = if h == "" then h 274 -- else if head h == '*' then lib ++ tail h 275 -- else h ++ ".pat" 276 -- lib = "/n/johann/usr2/openday/reptile/potato/" --CR now where? 277 -- infromfile = case openfile patfile of 278 -- No emsg -> ( emsg ++ "\n" ++ delay 1000 ++ tpgrid 279 -- , tilist ) 280 -- Yes ls8 -> ( concat (map2 put (map squas alistind) 281 -- (pam (orient xymax) orilist wcoords)) 282 -- , zip alistind orilist ) 283 -- where 284 -- orilist = concat (map stoil (lines ls8)) 285 -- -- have omitted @ tgrid after cleara tilearea 286 -- out = menumark "tget" ++ 287 -- cleara tilearea ++ 288 -- prompt ++ 289 -- fst infromfile ++ 290 -- clearit ++ 291 -- unmenumark "tget" 292 293 t4' _ (dlist,sel,tilist) inpt = 294 (out,(dlist,sel,newtilist),inpt) 295 where 296 orilist = pam assoc [(0,0),(0,1),(1,0),(1,1)] tilist 297 wcoords = map (map wscale) (map fst dlist) 298 pic = t4 (pam (orient xymax) orilist wcoords) 299 newtilist = zip alistind (concrep 4 (cr12 ++ cr34)) 300 where 301 cr12 = concrep 4 [n1,n2] 302 cr34 = concrep 4 [n3,n4] 303 [n1,n2,n3,n4] = orilist 304 out = menumark "t4" ++ 305 cleara tilearea ++ 306 tile tpxorig tpyorig 4 4 pic ++ 307 unmenumark "t4" 308 309 assoc :: (Eq a) => a -> [(a,b)] -> b 310 assoc i ((j,v):ivs) = if i == j then v else assoc i ivs 311 312 q :: [Char] -> Trans 313 q _ state _ = ("",state,[]) 314 315 {- UNUSED: 316 prompt :: [Char] 317 prompt = clearit ++ 318 vistextreg ++ 319 func 4 ++ 320 stringto 0 50 600 "Type in filename: " ++ 321 func 15 322 323 clearit :: [Char] 324 clearit = cleara textarea 325 326 totext :: [[Int]] -> [Char] 327 totext = concat . map putline 328 329 putline :: [Int] -> [Char] 330 putline [x0,y0,x1,y1] = "cs " ++ show x0 ++ " " ++ show y0 ++ " " ++ 331 show x1 ++ " " ++ show y1 ++ "\n" 332 -} 333 334 -- newdraw clears and redraws the design area, and the picarea. 335 -- also the tile area 336 -- It is used by dclear and by get 337 newdraw :: [Char] 338 newdraw = cleara designarea ++ 339 dpgrid ++ 340 cleara picarea ++ 341 picgrid ++ 342 cleara tilearea ++ 343 tpgrid ++ 344 invisibletext ++ 345 todesign 346 347 potatotile :: State -> [[Char]] -> [Char] 348 potatotile = inter tileprompt tilequit tiletrans 349 350 stoil :: [Char] -> [Int] 351 stoil = map read . words 352 353 354