Ville Tirronen
20.10.2011
README vastaamaan ryhmän aitoa kokoonpanoa.{-#LANGUAGE ScopedTypeVariables#-}
module Main where
import Test.QuickCheck hiding (elements)
import Control.Applicative
import Graphics.Gloss
import Graphics.Gloss.Data.Color
import System.Random
-- # Johdanto
-- Tämä on luennoijan oma esimerkkivastaus `Death-by-suorakaide` demotehtäviin.
-- Vastauksessa on tyysti jätetty huomiotta tehokkuus (Oikeasti käyttäisin
-- nelipuuta) ja eksakti tehtävien formaatti. Myöskin pari bugia on jätetty,
-- osaksi jopa tahallaan, ohjelmaan.
-- Suorakaide-tyyppi
data Rectangle a = R a a a a deriving (Eq,Show)
-- "Smart Constructor". Jos normalisoimme suorakaiteen jo luontivaiheessa,
-- säästämme aivan älyttömästi vaivaa myöhemmin.
mkR a b c d = R (min a c) (min b d) (max a c) (max b d)
-- pistevieraiden suorakaiteiden joukko.
newtype Area a = A [Rectangle a] deriving (Eq,Show)
-- Alueen suorakaiteet
elements (A x) = x
-- Onko alue tyhjä?
nullArea :: (Num a, Eq a) => Area a -> Bool
nullArea = (0 ==) . sum . map areaR . elements
-- Arbitrary instanssi suorakaiteille. Käytämme pieniä lukuja, että saamme
-- helposti visualisoitua testejä gloss kirjastolla.
instance (Random a, Num a, Ord a, Arbitrary a) => Arbitrary (Rectangle a)
where
arbitrary = mkR <$> choose (0,100) <*> choose (0,100)
<*> choose (0,100) <*> choose (0,100)
-- Arbitrary alueille. Koska osaamme tehdä arbitrary listoja ja arbitrary suorakaiteita
-- niin ainoa mikä jää tehtäväksi on muuttaa suorakaiteet "neliövieraiksi" alueiksi.
instance (Random a, Num a, Ord a, Arbitrary a) => Arbitrary (Area a)
where
arbitrary = unionRs <$> arbitrary
-- Suorakaiteen pinta-ala
areaR :: Num a => Rectangle a -> a
areaR (R l t r b) = (r-l)*(b-t)
-- Alueen pinta-ala
areaA :: Num c => Area c -> c
areaA (A xs) = sum . map areaR $ xs
-- # Leikkaukset
-- Tämä on esimerkki operaatiosta, joka on täysin toivoton tehdä, mikäli aloittaa
-- kahdella leikkaavalla alueella. Se on kuitenkin lähestulkoon triviaali, mikäli
-- se toteutetaan ensin janoille, sitten suorakaiteille ja vasta tämän jälkeen alueille.
-- Leikkaako kaksi "janaa" toisiaan?
intersect1D :: Ord a => (a, a) -> (a, a) -> Bool
intersect1D (x,y) (u,w) =
not $ (x <= min u w && y <= min u w) || (x >= max u w && y >= max u w)
-- Leikkaavatko kaksi suorakaidetta?
intersects :: (Ord a, Num a) => Rectangle a -> Rectangle a -> Bool
intersects re1@(R l1 t1 r1 b1) re2@(R l2 t2 r2 b2)
| areaR re1 > 0
&& areaR re2 > 0
&& intersect1D (l1,r1) (l2,r2)
&& intersect1D (t1,b1) (t2,b2) = True
| otherwise = False
-- Suorakaiteilla toimiva operaatio on hyvä yleistää ensin toisen parametrinsa
-- suhteen, jolloin saadaan hieman turhalta kuulostava alueen ja suorakaiteen
-- leikkaustesti. Tämä funktio kuitenkin helpottaa elämää lähes maagisesti kun
-- määritellään kahden alueen leikkausta. Huomaa kuinka samankaltaisia kaksi
-- seuraavaa funktiota ovat:
-- Leikkaavatko alue ja suorakaide toisiaan?
intersectsAR :: (Ord a, Num a) => Area a -> Rectangle a -> Bool
intersectsAR a b = any (intersects b) . elements $ a
-- Leikkaavatko kaksi aluetta toisiaan?
intersectsA :: (Ord a, Num a) => Area a -> Area a -> Bool
intersectsA a b = any (intersectsAR b) . elements $ a
-- Seuraavaksi yleinen suorakaiteiden leikkaus. Eroaville neliöille tämä laskee
-- niiden pienimmän yhdistäjän.
intersection :: Ord a => Rectangle a -> Rectangle a -> Rectangle a
intersection (R l1 t1 r1 b1) (R l2 t2 r2 b2)
= R (max l1 l2) (max t1 t2)
(min r1 r2) (min b1 b2)
-- Versio leikkauksesta, joka on tyypeiltään yhteensopiva yhdisteen kanssa.
-- Mikäli mahdollista, meidän tulee aina pyrkiä tämän kaltaiseen symmetriaan.
intersection' :: (Num a, Ord a) => Rectangle a -> Rectangle a -> Area a
intersection' a b
| intersects a b = A [intersection a b]
| otherwise = A []
-- Alueen ja suorakaiteen leikkaus. Tämä on jälleen eräänlainen apufunktio, jonka
-- pääasiallinen tehtävä on muuttaa kahden alueen leikkauksen määritelmä triviaaliksi.
intersectionAR :: (Ord a, Num a) => Area a -> Rectangle a -> Area a
intersectionAR a r = forEveryTile (`intersection'` r) a
-- Kahden alueen leikkaus
intersectionA :: (Ord a, Num a) => Area a -> Area a -> Area a
intersectionA a = forEveryTile (intersectionAR a)
-- Yhdisteen tekemiseksi joudumme pilkkomaan suorakaiteita osiin. Helpoimmalle
-- tuntui tehdä kaksi apufunktiota, jotka katkaisevat suorakaiteita akseleiden suhteen.
-- Suorakaiteen katkaisu y-akselin suuntaisesti
splitX :: Ord a => a -> Rectangle a -> [Rectangle a]
splitX x rt@(R l t r b)
| x <= l || x >= r = [rt]
| otherwise = [R l t x b, R x t r b]
-- Suorakaiteen katkaisu x-akselin suuntaisesti
splitY :: Ord a => a -> Rectangle a -> [Rectangle a]
splitY y rt@(R l t r b)
| y <= t || y >= b = [rt]
| otherwise = [R l t r y, R l y r b]
-- Kuten ryhmissä havaittiinkin, niin suorakaiteiden yhdistäminen on helpompi
-- määritellä, jos osataan laskea suorakaiteiden erotus: a `yhdiste` b = a `pois` b ++ b.
-- Poistaa neliöstä r1 neliön r2
difference :: (Ord a, Num a) => Rectangle a -> Rectangle a -> Area a
difference r1 r2@(R l t r b) = A $
filter (not . intersects r2)
$ splitX l r1 >>= splitX r >>= splitY t >>= splitY b
-- Poistaa alueen kaikista suorakaiteista suorakaiteen r.
differenceAR :: (Ord a, Num a) => Area a -> Rectangle a -> Area a
differenceAR a1 r = forEveryTile (`difference` r) a1
-- Poistaa alueesta a alueen b. Ts. jokaisesta a:n suorakaiteesta leikataan
-- pois kaikki mihin b osuu.
differenceA :: (Ord a, Num a) => Area a -> Area a -> Area a
differenceA a b = foldl (differenceAR) a (elements b)
-- Apufunktio - käytännössä concatMap alueelle
forEveryTile :: (Rectangle t -> Area a) -> Area t -> Area a
forEveryTile f (A rs) = A . concatMap (elements . f) $ rs
-- Lisää alueeseen `area` neliön r2. Alueesta ensin poistetaan
-- `r2`:n alle jäävät kohdat ja lisätään r2 sellaisenaan.
unionAR :: (Ord a, Num a) => Area a -> Rectangle a -> Area a
unionAR area r2
= let (A sub) = area `differenceAR` r2 in A $ r2:sub
-- Yhdistetään kaksi aluetta, ts. lisätään ensimmäiseen yksi kerrallaan
-- kaikki jälkimmäisen suorakaiteet.
unionA :: (Ord a, Num a) => Area a -> Area a -> Area a
unionA area (A rs) = foldl (unionAR) area rs
-- Kahden neliön yhdiste
unionR :: (Ord a, Num a) => Rectangle a -> Rectangle a -> Area a
unionR r1 r2
= let (A sub) = r1 `difference` r2 in A $ r2:sub
-- Apufunktio neliöjoukkojen yhdistämiseksi alueeksi.
unionRs :: (Ord a, Num a) => [Rectangle a] -> Area a
unionRs rs = foldl (unionAR) (A []) rs
-- Suorakaiteiden ja alojen visualisointia:
drawRect :: Integral t => Rectangle t -> Picture
drawRect (R l t r b) = pictures [color red . line $ path
,color yellowish . polygon $ path]
where
path = map (both fromIntegral) [(t,l),(t,r),(b,r),(b,l),(t,l)]
both f (a,b) = (f a, f b)
yellowish = makeColor 0.8 0.8 0.2 0.5
drawArea :: Integral t => Area t -> Picture
drawArea (A xs) = pictures $ map drawRect xs
main :: IO ()
main = do
let a= A [R 81 12 90 18]
b= A [R 64 23 86 34]
displayInWindow "test" (500,500) (20,20)
black
(pictures [drawArea $ differenceA a b
,translate 100 0 $ drawArea a
,translate 200 0 $ drawArea b ])iffiäcasenfoldia