fork download
copy 
  1. import Data.Ratio
  2.  
  3. main :: IO ()
  4. main = mapM_ printIntersection ls
  5.   where
  6.     ls =
  7.       [
  8.         ((Point 0 8      , Point 4 0) , (Point 2 4      , Point 8 12))
  9.       , ((Point 0 0      , Point 4 6) , (Point 0 0      , Point 7 15))
  10.       , ((Point 0 0      , Point 1 2) , (Point 1 1      , Point 2 3))
  11.       , ((Point (-9) (-9), Point 9 9) , (Point 5 0      , Point 5 7))
  12.       , ((Point 3 4      , Point 6 7) , (Point 3 8      , Point 9 (-1)))
  13.       , ((Point (-1) 0   , Point 4 18), (Point (-2) (-5), Point 1 3))
  14.       , ((Point 1 2      , Point 4 18), (Point 1 2      , Point 4 18))
  15.       ]
  16.  
  17. printIntersection :: (Segment, Segment) -> IO ()
  18. printIntersection (l, m) = putStrLn s
  19.   where
  20.     s =
  21.       if not (onSegment l && onSegment m) || any isNaN [x, y] then
  22.         "交点なし"
  23.       else
  24.         show (x, y)
  25.     Point x y = intersection (uncurry line l) (uncurry line m)
  26.  
  27.     onSegment :: Segment -> Bool
  28.     onSegment ((Point x1 y1), (Point x2 y2)) = checkX && checkY
  29.       where
  30.         checkX  = f x1 x x2
  31.         checkY  = f y1 y y2
  32.         f a b c = g (if a <= c then (<=) else (>=)) [a, b, c]
  33.         g op    = and . (flip (zipWith op) =<< tail)
  34.  
  35. type Segment = (Point, Point)
  36. data Point   = Point Double Double
  37. data Line    = Line Rational Rational Rational
  38.  
  39. line :: Point -> Point -> Line
  40. line (Point x1 y1) (Point x2 y2)
  41.   | dx /= 0   = Line (toRational slope) (-1) (toRational $ slope * x1 - y1)
  42.   | otherwise = Line 1 0 (toRational x1)
  43.   where
  44.     slope = dy / dx
  45.     dx    = x2 - x1
  46.     dy    = y2 - y1
  47.  
  48. intersection :: Line -> Line -> Point
  49. intersection l@(Line a b p) m@(Line c d q)
  50.   | not $ parallel l m = Point (fromRational x) (fromRational y)
  51.   | otherwise          = Point nan nan
  52.   where
  53.     x = invd * p + invb * q
  54.     y
  55.       | a == 0    = c * x + q
  56.       | c == 0    = a * x + p
  57.       | otherwise = invc * p + inva * q
  58.     [inva, invb, invc, invd] = map (/ det l m) [a, -b, -c, d]
  59.     nan :: Double
  60.     nan = 0 / 0
  61.  
  62. parallel :: Line -> Line -> Bool
  63. parallel l m = det l m == (0 % 1)
  64.  
  65. det :: Line -> Line -> Rational
  66. det (Line a b _) (Line c d _) = a * d - b * c
  67.  
Success #stdin #stdout 0s 6284KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
(2.0,4.0)
(0.0,0.0)
交点なし
(5.0,5.0)
(4.6,5.6)
交点なし
交点なし
https://ideone.com/bh7Gd3
language:
Haskell (ghc 8.4.4)
created:
11 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!