Haskell - 型引数と型コンストラクタ(Either a b型, Maybe a型(Left, Right, Nothing, Just)

すごいHaskellたのしく学ぼう!
(オーム社)
Miran Lipovača (著)
田中 英行 村主 崇行 (翻訳)
[Kindle版]

開発環境

• OS X Mavericks - Apple(OS)
• BBEdit - Bare Bones Software, Inc., Emacs (Text Editor)
• Haskell (純粋関数型プログラミング言語)
• GHC (The Glasgow Haskell Compiler) (処理系)
• The Haskell Platform (インストール方法、モジュール等)

初めてのコンピュータサイエンス(Jennifer Campbell、Paul Gries、Jason Montojo、Greg Wilson(著)長尾 高弘(翻訳))の12章(各種ツール)、12.7(練習問題)、12-4、5.をHaskellで解いてみる。

その他参考書籍

• プログラミングHaskell (オーム社) Graham Hutton(著) 山本 和彦(翻訳)
• Real World Haskell―実戦で学ぶ関数型言語プログラミング (オライリージャパン) Bryan O'Sullivan John Goerzen Don Stewart(著) 山下 伸夫 伊東 勝利 株式会社タイムインターメディア(翻訳)

12.7(練習問題)、12-4、5.

コード(BBEdit)

Sample.hs

{-# OPTIONS -Wall -Werror #-}

main :: IO ()
main = mapM_ print $ map (\(line1, line2) -> lineIntersect line1 line2) 
                         testLinePairs

data Point = Point {getX :: Double, getY :: Double} deriving (Show, Eq)
data Line = Line {getA :: Point, getB :: Point} deriving (Show, Eq)

lineIntersect :: Line -> Line -> Either String (Either Line (Maybe Point))
lineIntersect line1 line2 =
    let new_line1@(Line (Point a1 b1) (Point c1 d1)) = newLine line1
        new_line2@(Line (Point a2 b2) (Point c2 d2)) = newLine line2
        slope1 = slope new_line1
        slope2 = slope new_line2
        y_intercept1 = yIntercept new_line1
        y_intercept2 = yIntercept new_line2
        infinity = 1.0 / 0
        y1 = slope1 * a2 - y_intercept1
        y2 = slope2 * a1 - y_intercept2
        x = - (y_intercept1 - y_intercept2) / (slope1 - slope2)
        y = slope1 * x + y_intercept1
    in if slope1 == slope2 then
           if new_line1 == new_line2 then
               Left "Geometry"
           else
               if y_intercept1 == y_intercept2 then
                   if a1 > c2 || c1 < a2 then
                       Right $ Right Nothing
                   else
                       if (a1 == c1 && b1 == c2) || (c1 == a2 && d1 == b2) then
                           if a1 == c1 then
                               Right $ Right $ Just $ Point a1 b1
                           else
                               Right $ Right $ Just $ Point c1 d1
                       else
                           Right $ Left line1
               else
                   Right $ Right Nothing
       else
           if slope1 == infinity then
               if a1 < a2 || a1 > c2 || y2 < b1 || y2 > d1 then
                   Right $ Right Nothing
               else
                   Right $ Right $ Just $ Point a1 y2
           else
               if slope2 == infinity then
                   if a2 < a1 || a2 > c1 || y1 < b2 || y1 > d2 then
                       Right $ Right Nothing
                   else
                       Right $ Right $ Just $ Point a2 y1
               else
                   if a1 <= x && x <= c1 && a2 <= x && x <= c2 &&
                          min b1 d1 <= y && y <= max b1 d1 &&
                          min b2 d2 <= y && y <= max b2 d2 then
                       Right $ Right $ Just $ Point x y
                   else
                       Right $ Right Nothing
                    


newLine :: Line -> Line
newLine line@(Line (Point a b) (Point c d)) =
    if a > c || (a == c && b > d) then
        Line (Point c d) (Point a b)
    else
        line        

slope :: Line -> Double
slope (Line (Point a b) (Point c d)) = (d - b) / (c - a)

yIntercept :: Line -> Double
yIntercept line@(Line (Point a b) _) = b - slope line * a

testLinePairs :: [(Line, Line)]
testLinePairs = [(Line (Point 0 0) (Point 1 1), Line (Point 1 0) (Point 2 1)),
                 (Line (Point 0 0) (Point 1 1), Line (Point 0 1) (Point 1 0)),
                 (Line (Point 0 0) (Point 1 1), Line (Point 1 1) (Point 2 2)),
                 (Line (Point 0 0) (Point 1 1), Line (Point 0 0) (Point 1 1)),
                 (Line (Point 0 0) (Point 2 2), Line (Point 1 1) (Point 3 3))]

入出力結果(Terminal, runghc)

$ runghc Sample.hs
Right (Right Nothing)
Right (Right (Just (Point {getX = 0.5, getY = 0.5})))
Right (Right (Just (Point {getX = 1.0, getY = 1.0})))
Left "Geometry"
Right (Left (Line {getA = Point {getX = 0.0, getY = 0.0}, getB = Point {getX = 2.0, getY = 2.0}}))
$

慣れるまでは{-# OPTIONS -Wall -Werror #-}の記述を消さずに細かく型を指定していくことに。