Viikkotehtävä 1

viikko1.hs

{-

110 viikkovisa #1
---------------------------

Piirretään ruutupaperille numeroita myötäpäivään "ympyrään" alkaen vasemmasta yläkulmasta:
1
...
1 2
...
1 2
  3
...
1 2
4 3
...
1 2 5
4 3
...
...
1 2 5 10
4 3 6 jne.
9 8 7

Missä ruudussa (rivi / sarake) on numero 723522?
-}

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

import Test.Framework (defaultMain, testGroup)
import Test.Framework.Providers.HUnit (testCase)
import Test.Framework.Providers.QuickCheck2 (testProperty)

import Test.HUnit
import Test.QuickCheck

{-
 
 Case: n = 10

 1 2 5 10
 4 3 6
 9 8 7

 a = 3
 b = 4
 r = 1
 d = -3

 Case: n = 8

 1 2 5
 4 3 6
   8 7

 a = 2
 b = 3
 r = 4
 d = 1
 -}

-- | Absoluuttisen paikan haistelua. Huijausta siis.
--
-- O(1), jos sqrt on O(1)
-- n -> (sarake, rivi)
viikko1 :: Int -> (Int, Int)
viikko1 n = let
    a = floor $ sqrt $ fromIntegral (n-1)
    b = a + 1
    r = n - a * a
    d = r - b
  in if d <= 0
        then (b, r)
        else (b - d, b)

-- | Neliö
sq x = x*x

-- | Babylonian. Luulisi että olisi valmiina

floorSqrt :: Integral n => n -> n
floorSqrt s = iter 1
  where iter xn | sq xn <= s && sq (xn+1) > s = xn
                | otherwise                   = iter $ (xn + s `quot` xn) `quot` 2

floorSqrt' :: Integral n => n -> n
floorSqrt' s = iter s
  where iter xn | sq xn <= s = xn
                | otherwise  = iter $ xn - 1

-- | Sama kuin `viikko1`, mut toimii ihan niin isoilla luvuilla ku muistiin mahtuu.
-- O(log n), floorSqrt konvergoi neliöllisesti
viikko1a :: Integral n => n -> (n,n)
viikko1a n = let
    a = floorSqrt $ fromIntegral (n-1)
    b = a + 1
    r = n - a * a
    d = r - b
  in if d <= 0
        then (b, r)
        else (b - d, b)

-- | Same ku `viikko1a` mut käyttäen `floorSqrt'`
-- O(n)
viikko1a' :: Integral n => n -> (n,n)
viikko1a' n = let
    a = floorSqrt' $ fromIntegral (n-1)
    b = a + 1
    r = n - a * a
    d = r - b
  in if d <= 0
        then (b, r)
        else (b - d, b)

-- | Kaikkien numeroiden sijainnit. Eikä mitään absoluuttisen paikan haistelua.
-- O(n) \equiv Hidas ku mikä
viikko1bNumbers = iterate f (1,1)
  where f (1, y)             = (y+1, 1)
        f (x, y) | x > y     = (x, y+1)
                 | otherwise = (x-1, y)

viikko1b :: Int -> (Integer, Integer)
viikko1b n = viikko1bNumbers !! (n-1)

-- * Tests

-- ** Unit Tests
viikko1Test f n r = testCase name $ f n @?= r
  where name = "viikko1 " ++ show n ++ " = " ++ show r

unitTests name f = testGroup name ts
  where ts = [ t 1 (1,1)
             , t 2 (2,1)
             , t 3 (2,2)
             , t 4 (1,2)
             , t 5 (3,1)
             , t 6 (3,2)
             , t 7 (3,3)
             , t 8 (2,3)
             , t 9 (1,3)
             , t 10 (4,1)
             ]
        t  = viikko1Test f

-- ** QuickCheck properties
viikko1a_viikko1b_prop:: SmallPositive Int -> Bool
viikko1a_viikko1b_prop n = (viikko1a :: Integer -> (Integer, Integer)) (fromIntegral n) == (viikko1b :: Int -> (Integer, Integer)) (fromIntegral n)

viikko1a_viikko1a'_prop:: VerySmallPositive Int -> Bool
viikko1a_viikko1a'_prop n = (viikko1a :: Integer -> (Integer, Integer)) (fromIntegral n) == (viikko1a' :: Integer -> (Integer, Integer)) (fromIntegral n)

square_huijaus_prop :: VerySmallPositive Int -> Bool
square_huijaus_prop n = (n + 1, 1) == (viikko1a $ sq n + 1)

-- | Positive numbers 1..1000001
newtype SmallPositive a = SmallPositive a
 deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read )

instance (Integral a, Ord a, Arbitrary a) => Arbitrary (SmallPositive a) where
  arbitrary = (SmallPositive . (1+) . (`mod` 100000) . abs) `fmap` arbitrary

  shrink (SmallPositive x) =
    [ SmallPositive x'
    | x' <- shrink x
    , x' > 0
    ]

-- | Positive numbers 1..101
newtype VerySmallPositive a = VerySmallPositive a
 deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read )

instance (Integral a, Ord a, Arbitrary a) => Arbitrary (VerySmallPositive a) where
  arbitrary = (VerySmallPositive . (1+) . (`mod` 101) . abs) `fmap` arbitrary

  shrink (VerySmallPositive x) =
    [ VerySmallPositive x'
    | x' <- shrink x
    , x' > 0
    ]

-- ** Test framework
tests = [ testGroup "QuickCheck" [ testProperty "viikko1a === viikko1b" viikko1a_viikko1b_prop
                                 , testProperty "viikko1a === viikko1a'" viikko1a_viikko1a'_prop
                                 , testProperty "huijausominaisuus" square_huijaus_prop
                                 ]
        , testGroup "HUnit" [ unitTests "viikko1" viikko1
                            , unitTests "viikko1a" viikko1a
                            , unitTests "viikko1b" viikko1b
                            ]
        ]

-- | Run tests and calculate
main :: IO ()
main = do
  putStrLn "viikko1 723522:"
  print $ viikko1 723522
  print $ viikko1a 723522
  print $ viikko1b 723522
  defaultMain tests