fork download 
  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 1 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 any isNaN [x, y] || not (onSegment l && onSegment m) 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 (Line a b p) (Line c d q)
  50.   | not $ parallel = Point (fromRational x) (fromRational y)
  51.   | otherwise      = Point nan nan
  52.   where
  53.     x = invd * p + invb * q
  54.     y = invc * p + inva * q
  55.     [inva, invb, invc, invd] = map (/ det) [a, -b, -c, d]
  56.     nan :: Double
  57.     nan = 0 / 0
  58.     parallel :: Bool
  59.     parallel = det == 0
  60.     det :: Rational
  61.     det = a * d - b * c
  62.  
Success #stdin #stdout 0s 6280KB
comments (?)
stdin 
Standard input is empty
stdout 
(1.6363636363636365,4.7272727272727275)
(0.0,0.0)
交点なし
(5.0,5.0)
(4.6,5.6)
交点なし
交点なし
https://ideone.com/pYLkxF
language:
Haskell (ghc 8.4.4)
created:
10 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!