Haskell卒業!

■ [アルゴリズム]グラハム・スキャン再び... 05:43

昔書いたコードを復習していてあまりにも酷いので書き直した...

グラハム・スキャンって、要はco-tangentでソートして外積でグルグル回ってるだけだよなぁ...と...

よく確認してないので間違ってるかもしれないけど、実際使うことはないからおｋ。考え方が身に付けばいいや...

方針的に座標平面上の点をタプルで表してNumのインスタンスにしようと思ったけど、メンドイのでApplicativeのインスタンスにしたら余計にメンドかった...orz

でも、Functorのインスタンスにもなってるから計算とか簡単...

重要なのはCounter-Clock-Wise(外積の値の正負)によって点の取捨選択をする部分ではなく、それ以前のソート。ソート時に角度が同じならXY軸の値の小さい方が先に来る様にしておくと次のスキャンが簡単に書ける...

import Control.Applicative
import Data.List
import Data.Ratio
import Test.QuickCheck
import Test.QuickCheck.Checkers
import Test.QuickCheck.Classes(applicative)
import Text.Printf

newtype Pair a = Pair(a,a)
 deriving (Eq,Ord)

instance (Show a)=>Show(Pair a) where
 show(Pair x) = show x

-- Applicativeなしではいられない体になってしまった...
instance Functor Pair where
 fmap f (Pair(y,x)) = Pair(f y,f x)

instance Applicative Pair where
  pure f = Pair(f,f)
  (Pair(g,f))<*>(Pair(y,x)) = Pair(g y,f x)

-- CheckersでApplicative則を確認...
instance (Arbitrary a)=>Arbitrary(Pair a) where
  arbitrary = Pair<$>arbitrary

instance (EqProp a)=>EqProp(Pair a) where
  Pair a=-=Pair b = a=-=b

instance EqProp Integer where
  (=-=) = (property.).(==)

instance (Integral a)=>EqProp(Ratio a) where
  (=-=) = (property.).(==)

checkApplicativeLaws :: IO()
checkApplicativeLaws = mapM_ quickBatch
  [
  -- 数値型を重点的に調べる...
    applicative(undefined :: Pair(Int,Int,Int))
  , applicative(undefined :: Pair(Integer,Integer,Integer))
  , applicative(undefined :: Pair(Rational,Rational,Rational))
  , applicative(undefined :: Pair(Float,Float,Float))
  , applicative(undefined :: Pair(Double,Double,Double))
  -- 一応、forall aなので、どんな型を中に入れても成り立つことをチェック...
  , applicative(undefined :: Pair(String->Int,[Int],Maybe Bool))
  ]

-- コード本体...
type Vector = Pair Int

cross :: Vector->Vector->Int
cross(Pair(y1,x1))(Pair(y2,x2)) = x1*y2-x2*y1

comparingCotangents :: Vector->Vector->Vector->Ordering
comparingCotangents org p1 p2
 |y1==0&&y2==0 = x1`compare`x2
 |y1==0        = LT
 |y2==0        = GT
 |res==EQ      = y1`compare`y2
 |otherwise    = res
 where Pair(y1,x1) = (-)<$>p1<*>org
       Pair(y2,x2) = (-)<$>p2<*>org
       res = (x2%y2)`compare`(x1%y1)

-- グルグル回るだけだった...
convexHull(p1:org:stack)(p2:ps)
 |((-)<$>p1<*>org)`cross`((-)<$>p2<*>org)>0 = convexHull(p2:p1:org:stack)ps
 |otherwise                                 = convexHull(org:stack)(p2:ps)
convexHull (org:stack)(p:ps)                = convexHull(p:org:stack)ps
convexHull done _                           = reverse done

-- 確認(かなり適当...)
points :: [Vector]
points = Pair<$>[(1,0),(0,0),(0,1),(2,0),(0,2),(1,1),(2,2),(1,2),(2,1),(1,3),(3,0)]

check :: IO()
check = do
  let org = minimum points
      others = sortBy(comparingCotangents org).delete org$nub points
  printf"The bottom left most point:\n-> %s\n".show$org
  printf"The other points sorted by comparing their co-tangents:\n-> %s\n".show$others
  printf"Convex hull:\n-> %s\n".show$convexHull[org]others

一応、実行結果...

$> check
The bottom left most point:
-> (0,0)
The other points sorted by comparing their co-tangents:
-> [(0,1),(0,2),(1,3),(1,2),(1,1),(2,2),(2,1),(1,0),(2,0),(3,0)]
Convex hull:
-> [(0,0),(0,2),(1,3),(2,2),(3,0)]

あと、Applicative則の確認...

つか、FloatとかDoubleって、それ自身に誤差を含むから成り立つ方がおかしい気もするけど、何故かパスした。値が極端に違う場合、左畳み込みと右畳み込みで普通に(==)がFalseを返すことはありそうだけど？？？

$> checkApplicativeLaws

applicative:
  identity:     +++ OK, passed 500 tests.
  composition:  +++ OK, passed 500 tests.
  homomorphism: +++ OK, passed 500 tests.
  interchange:  +++ OK, passed 500 tests.
  functor:      +++ OK, passed 500 tests.

applicative:
  identity:     +++ OK, passed 500 tests.
  composition:  +++ OK, passed 500 tests.
  homomorphism: +++ OK, passed 500 tests.
  interchange:  +++ OK, passed 500 tests.
  functor:      +++ OK, passed 500 tests.

applicative:
  identity:     +++ OK, passed 500 tests.
  composition:  +++ OK, passed 500 tests.
  homomorphism: +++ OK, passed 500 tests.
  interchange:  +++ OK, passed 500 tests.
  functor:      +++ OK, passed 500 tests.

applicative:
  identity:     +++ OK, passed 500 tests.
  composition:  +++ OK, passed 500 tests.
  homomorphism: +++ OK, passed 500 tests.
  interchange:  +++ OK, passed 500 tests.
  functor:      +++ OK, passed 500 tests.

applicative:
  identity:     +++ OK, passed 500 tests.
  composition:  +++ OK, passed 500 tests.
  homomorphism: +++ OK, passed 500 tests.
  interchange:  +++ OK, passed 500 tests.
  functor:      +++ OK, passed 500 tests.

applicative:
  identity:     +++ OK, passed 500 tests.
  composition:  +++ OK, passed 500 tests.
  homomorphism: +++ OK, passed 500 tests.
  interchange:  +++ OK, passed 500 tests.
  functor:      +++ OK, passed 500 tests.
(206.09 secs, 50968702148 bytes)