-- | The entire world, implemented as a single fudget, instead of one fudget -- per object in the world. module WorldF(worldF,worldF') where import System.Random import Control.Applicative import Control.Monad(when) import Data.List(nub) import ReactionM import GUI import InvaderTypes hiding (Phase(..)) data World = W {rnd::StdGen, shelters::Shelters, base::Base, ufo::Ufo, torpedo::Torpedo, vshots::VShots, invaders::Invaders} data Base = B {bPict,exbPict::Pict, bPos::Point, lives::Int, bSpeed::Speed} | ExB {bPict,exbPict::Pict, bPos::Point, lives::Int, exbAge::Int} --data Shelters = Sh [PlacedPict] -- hmm type Shelters = [Shelter] data Shelter = Sh {shGC::GCId,shBR::Rect,shRs::[Rect]} data Torpedo = T Pict (Maybe Point) data Ufo = U Pict GCId UfoState data UfoState = Wait Ticks | Moving Score Speed Point | Hit Ticks Score Point data VShots = V Speed (Pict,Pict) [Point] data VShot = V1 Speed (Pict,Pict) Point data Invaders = Invs {invs::[Invader], level::Int, step::Speed, delay::Ticks} data Invader = Inv {invPict::(Pict,Pict),exvPict::Pict, invScore::Int,invPos::Point} | Exv {exvPict::Pict, invPos::Point} -- exploded type ExVader = Pict type Speed = Int type Ticks = Int type Score = Int modBase = update . updateBase updateBase f w@W{base=b} = w{base=f b} --updateTorpedo f =w@W{torpedo=t} = w{torpedo=f b} exBase (B pm ex p l v) = ExB pm ex p l 0 exBase base = base alive w = case base w of B {} -> True; _-> False spare pm n = if n>=0 then hboxD (replicate n (atomicD (Right pm))) else atomicD (Left "Game over!") -------------------------------------------------------------------------------- worldF g = spaceF (initWorldK g) objectsK worldF' g = spaceF' (initWorldK g) objectsK -------------------------------------------------------------------------------- initWorldK g m = W g <$> initSheltersK m <*> initBaseK m <*> initUfoK m <*> initTorpedoK m <*> initVShotsK m <*> initInvadersK m initSheltersK metrics = do gc <- objGC shelterColor let sh p = Sh gc (Rect p s) (move p shape) return $ map sh ps where s@(Point w h) = shelterSize metrics m = (spaceWidth metrics -3*3-7*w) `div` 2 y = spaceHeight metrics-margin metrics-3*h xs = [m+2*(w+3)*i|i<-[0..3]] ps = [Point x y|x<-xs] shape = [v x roofy h|x<-[0..roofx-1]]++ [v x 0 h|x<-[roofx..legx-1]]++ [v x 0 (h-legy)|x<-[legx..w-legx-1]]++ [v x 0 h|x<-[w-legx..w-roofx-1]]++ [v x roofy h|x<-[w-roofx..w-1]] v x y1 y2 = rR x y1 1 (y2-y1) legx = w `div` 3 - 1 legy = h `div` 4 roofy = legy roofx = w `div` 10 initBaseK m = do pict <- readObjPict m Base ex <- readObjPict m Explode let startpos = (baseStartPos m pict){xcoord= -width pict} lives = 3 putLivesMkc m (spare pict lives) return (ExB pict ex startpos (lives+1) 50) baseStartPos m pict = Point (margin m) (spaceHeight m-height pict-margin m) initUfoK m = do gc <- objGC ufoColor pict <- readPict m gc Ufo return $ U pict gc (Wait ufoDelay) initTorpedoK m = do gc <- objGC shotColor let s = torpedoSize m pict = rectangles gc s [Rect 0 s] return (T pict Nothing) initVShotsK m = flip (V (vshotDy m)) [] <$> readObjPicts m (phases VShot) initInvadersK m = invaders <$> mapM (readObjPicts m . phases . Vader) rows <*> mapM (readObjPict m . VExplode) rows where invaders is es = Invs invs startLevel dx0 16 where invs = zipWith centerI (concatMap row [i3,i3,i2,i2,i1]) places [i1,i2,i3] = zip3 is es [30,20,10] row = replicate hcount places = [Point (margin m+hsep*x) (margin m+vsep*y+offset)| y<-[5,4..1],x<-[0..hcount-1]] offset = invHeight m * min 8 startLevel centerI (pm@(pm1,_),ex,score) p = Inv pm ex score (p + pP ((invWidth m-width pm1) `div` 2) 0) hsep = invWidth m+2*bmScale m vsep = invHeight m+4*bmScale m dx0 = invDx m -------------------------------------------------------------------------------- type Output = Either Bases (Maybe Score) type Input = Either Tick Click type Bases = Drawing () Pict --getGs = toMs getG --putLivesMs l = toMsc (putLives l) --putScoreMs s = toMsc (putScore s) --putGUIMs g = toMsc (putGUI g) --puatsGUIMs gs = toMsc (putsGUI gs) --objectsK :: Size -> World -> Mk (G Input Output) () objectsK m world0 = reactiveSP (objectsKs m world0) world0 --objectsKs :: Size -> World -> Ms (G Input Output) World noreturn objectsKs m world0 = playK where playK = message low high where high = either (const tickK) (const newK) newK = do set world1 putGUI (clearRect (Rect 0 (spaceSize m)) True) putScore Nothing b <- field base putLives m (spare (bPict b) (lives b-1)) where world1 = world0{invaders=invs1} invs1 = invs0{invs=[],delay=100} invs0 = invaders world0 low ev = case ev of Redraw -> draw =<< get Key Fire Down -> fireTorpedo Key a p -> modBase (accelerate p a) accelerate pressed button b@ExB{} = b accelerate pressed button b@B{bSpeed=v} = b{bSpeed=v'} where v' = case pressed of Down -> bdir ; _ -> 0 bdir = case button of MoveLeft -> -baseDx m MoveRight -> baseDx m _ -> 0 tickK = do tickInvadersK tickUfoK W g shelters base ufo torpedo vshots invaders <- get base' <- tickBaseK base (torpedo',invaders',shelters',ufo')<- tickTorpedoK torpedo invaders shelters ufo set (W g shelters' base' ufo' torpedo' vshots invaders') tickVShotsK vshots base' tickInvadersK = do state@W{invaders=inv} <- get let t = delay inv-1 case t of 0 -> do let invcnt = length (invs inv) l = level inv+1 offset = pP 0 (invHeight m*(min 8 l-startLevel)) inv' = if invcnt==0 then move offset (invaders world0){level=l} else inv{delay=(invcnt+6) `div` 4} set state{invaders=inv'} moveInvadersK update fireVShot _ -> do let inv' = inv{delay=t} set state{invaders=inv'} --tickBaseK :: Base -> Ms (G hi (Either Bases x)) s Base tickBaseK b@(ExB pm ex p@(Point x y) l t) = case t of 50 -> putGUI (clearpm p pm) >> return b'{bPos=Point (-width pm) y} 95 | l>0 -> putLives m (spare pm (l-2)) >> return b' 100 | l>1 -> do let b' = B pm ex (baseStartPos m pm) (l-1) 0 draw b' return b' _ -> return b' where b' = b{exbAge=t+1} new = B pm ex tickBaseK b@(B pm ex p@(Point x y) l v) = case v of 0 -> return b _ -> putGUI (clearpm p pm) >> draw b' >> return b' where b' = B pm ex p' l v p' = Point x' y x' = min (spaceWidth m-margin m-width pm) (max (margin m) (x+v)) tickUfoK = do state@W{rnd=g,ufo=u@(U pm gc s)} <- get let ufoWidth = xcoord (size pm) case s of Wait 0 -> do let u'=U pm gc (Moving score dx (pP x0 (margin m))) score = 50*n (x0,dx) = if rev then (spaceWidth m,-ufoDx m) else (-ufoWidth,ufoDx m) (n,g') = randomR (1,6) g (rev,g'') = random g' draw u' set state{rnd=g'',ufo=u'} Wait t -> set state{ufo=U pm gc (Wait (t-1))} Hit 0 s p -> do putGUI (clearpm p pm) set state{ufo=U pm gc (Wait ufoDelay)} Hit t s p -> set state{ufo=U pm gc (Hit (t-1) s p)} Moving s dx p -> if dx>0 && xcoord p>=spaceWidth m || dx<0 && xcoord p< -ufoWidth then do putGUI (clearpm p pm) set state{ufo=U pm gc (Wait ufoDelay)} else do let p' = p + pP dx 0 u' = U pm gc (Moving s dx p') putGUI (clearpm p pm) draw u' set state{ufo=u'} tickTorpedoK t@(T pm optp) inv sh ufo = case optp of Nothing -> return (t,inv,sh,ufo) Just p@(Point x y) -> if y> return (T pm Nothing,inv,sh,ufo) else case p `invHit` inv of (inv1,Inv (p1,_) ex score ip:inv2) -> do putsGUI [clear p (torpedoSize m), clearpm ip p1] draw exv putScore (Just score) return (T pm Nothing,inv{invs=inv'},sh,ufo) where inv' = inv1++exv:inv2 exv = Exv ex ip _ -> case shelterHit' sh r d of Just sh' -> do putGUI (clearRect d False) return (T pm Nothing,inv,sh',ufo) _ -> case Rect p (size pm) `ufoHit` ufo of Just ufo'@(U upm _ (Hit _ score up)) -> do putGUI (clearpm p pm) putGUI (clearpm up upm) draw ufo' putScore (Just score) return (T pm Nothing,inv,sh,ufo') _ -> do let t' = move (pP 0 (-torpedoDy m)) t putGUI (clearpm p pm) draw t' return (t',inv,sh,ufo) where s = size pm r = Rect (p+pP 0 (torpedoDy m `div` 2)) s d = Rect (p-pP 1 0) (s+pP 2 0) r `ufoHit` U pm gc (Moving s dx p) | overlaps r (Rect p (size pm)) = Just (U pm gc (Hit 100 s p)) r `ufoHit` _ = Nothing p `invHit` Invs{invs=is} = break isHit is where isHit Exv{} = False isHit (Inv (p1,_) _ _ ip) = p `inRect` r where r = Rect (ip + Point 2 0) (size p1 - Point 4 0) fireTorpedo = do a <- field alive when a $ do update fire; draw =<< field torpedo fire w@W{torpedo=T gc t} = case t of Nothing -> w{torpedo=T gc (Just (firePos m (base w)))} _ -> w fireVShot w@W{vshots=V dy pm@(p1,_) ps,invaders=Invs{invs=is},rnd=g0} = if null is || length ps>5 then w else if r<9 then w{rnd=g1} else w{vshots=V dy pm (p:ps),rnd=g'} where p = Point (x+(invWidth m-width p1) `div` 2) (y+invHeight m-3*bmScale m) y = maximum [ycoord p|Inv{invPos=p}<-is,abs (xcoord p-x) do w<-get set w{shelters=sh'} putGUI (clearRect dr False) --draw sh' return Nothing _ -> if ycoord p' < spaceHeight m then do putsGUI [clearpm p p1,wDraw (V1 dy pm p')] return (Just p') else do putGUI (clearpm p p1) return Nothing where p' = p+v sr = Rect p ss hr = move (pP 0 (dy-h)) sr dr = sr hitBase = overlaps br sr moveInvadersK = do w@W{invaders=invs0,shelters=ss} <- get let (movecmds,br',invs') = moveInvaders invs0 putsGUI (concat movecmds) ss' <- if any (overlaps br' . shBR) ss then let shHit ss i@Inv{} = maybe ss id.shelterHit ss $ rect i shHit ss _ = ss in return $ foldl shHit ss (invs invs') else return ss set w{invaders=invs',shelters=ss'} moveInvaders (Invs is l dx dt) = (movecmds,br,Invs is' l dx' dt') where dt' = if null is' then 200 else if off_bottom then -1 else dt (dx',d) = if dx>0 && off_right || dx<0 && off_left then (-dx,pP 0 (invDy m)) else (dx,pP dx 0) (xs,ys) = unzip [(x,y)|Inv{invPos=Point x y}<-is] off_left = min_x < margin m off_right = max_x > spaceWidth m-margin m off_bottom = max_y > spaceHeight m-margin m min_x = minimum xs min_y = minimum ys max_x = maximum xs + invWidth m max_y = maximum ys + invHeight m br = if null xs then Rect 0 0 else move d $ line2rect (lL min_x min_y max_x max_y) (movecmds,is0') = unzip (map moveInvader is) is' = [i|Just i<-is0'] moveInvader (Exv p1 p) = ([clearpm p p1],Nothing) moveInvader (Inv (p1,p2) ex s p) = case ycoord d of 0 -> ([wDraw i'],Just i') _ -> ([clearpm p p1,wDraw i'],Just i') where i' = Inv (p2,p1) ex s (p+d) shelterHit ss r = shelterHit' ss r r shelterHit' ss r d = case break (hitSh r) ss of (pps1,Sh gc br rs:pps2) -> if any (overlaps r) rs && rs' /= rs then if null rs' then Just (pps1++pps2) else Just (pps1++Sh gc br rs':pps2) else Nothing where rs' = concat [diffRect sr d|sr<-rs] _ -> Nothing hitSh r (Sh _ br _) = overlaps r br -------------------------------------------------------------------------------- draw obj = putGUI (wDraw obj) instance Draw World where drawing w =drawing (ufo w,(shelters w,base w,torpedo w),(vshots w,invaders w)) --instance Draw Shelters where -- drawing (Sh pps) = pps instance Draw Shelter where drawing (Sh gc (Rect p s) rs) = [pp (rectangles gc s rs) 0] instance Draw Base where drawing (B pm ex p _ _) = [pp pm p] drawing (ExB pm ex p _ _) = [pp ex p] instance Draw Torpedo where drawing (T _ Nothing) = [] drawing (T pm (Just p)) = [pp pm p] instance Draw Ufo where drawing (U pm _ (Moving s dx p)) = [pp pm p] drawing (U pm gc (Hit t s p)) = [pp (text gc (show s)) (p+pP 0 (height pm))] drawing _ = [] instance Draw Invaders where drawing = drawing . invs instance Draw Invader where drawing (Inv (pm,_) _ _ p) = [pp pm p] drawing (Exv pm p) = [pp pm p] instance Draw VShots where drawing (V dy pm ps) = drawing [V1 dy pm p|p<-ps] instance Draw VShot where drawing (V1 dy (pm1,pm2) p) = [pp pm p] where pm = if even (ycoord p `div` dy) then pm1 else pm2 -------------------------------------------------------------------------------- class HasSize a => HasRect a where rect :: a -> Rect width obj = xcoord (size obj) height obj = ycoord (size obj) instance HasSize Base where size = size . bPict instance HasRect Base where rect (B pm _ p _ _) = Rect p (size pm) --instance HasSize Torpedo where size _ = torpedoSize instance HasSize Invader where size inv@Inv{invPict=(p1,_)} = size p1 size inv@Exv{exvPict=p1} = size p1 instance HasRect Invader where rect inv = Rect (invPos inv) (size inv) instance Move Base where move v (B pm ex p l dx) = B pm ex (p+v) l dx instance Move Torpedo where move v (T pm op) = T pm (move v op) instance Move Invaders where move v (Invs is l dx dt) = Invs (move v is) l dx dt instance Move Invader where move v inv@Inv{invPos=p} = inv{invPos=move v p} instance Move VShots where move v (V dy pm ps) = V dy pm (move v ps) -------------------------------------------------------------------------------- firePos m base = bPos base + pP (width base `div` 2) (-torpedoHeight m) shelterSize m = pP (20*bmScale m) (16*bmScale m) torpedoSize m = pP 1 (torpedoHeight m) torpedoHeight m = 8*bmScale m torpedoDy m = 6*bmScale m ufoDelay = argReadKey "ufodelay" 2500 ufoDx = bmScale vshotDy m = 2*bmScale m invHeight m = 8*bmScale m invWidth m = 12*bmScale m invDy m = 3*invHeight m `div` 4 invDx = bmScale margin m = 5*bmScale m baseDx m = argReadKey "dx" (2*bmScale m-1)::Int -- base speed hcount = argReadKey "hcount" 11::Int startLevel = argReadKey "level" 0::Int