Rotating caliper in Haskell

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
import Data.List
import Data.Array
import Data.Maybe
import Data.Function
import Text.Printf
import qualified Data.ByteString.Char8 as BS

data Point a = P a a deriving ( Show , Ord , Eq )
data Vector a = V a a deriving ( Show , Ord , Eq )
data Turn = S | L | R deriving ( Show , Eq , Ord , Enum  )

--start of convex hull

compPoint :: ( Num  a , Ord a ) => Point a -> Point a -> Ordering
compPoint ( P x1 y1 ) ( P x2 y2 )
  | compare x1 x2 == EQ = compare y1 y2
  | otherwise = compare x1 x2 

findMinx :: ( Num a , Ord a ) => [ Point a ] -> [ Point a ]
findMinx xs = sortBy ( \x  y  -> compPoint  x y  ) xs

compAngle ::(Num a , Ord a ) => Point a -> Point a -> Point a -> Ordering
compAngle ( P x1 y1 ) ( P x2 y2 ) ( P x0 y0 ) = compare ( (  y1 - y0 ) * ( x2 - x0 )  ) ( ( y2 - y0) * ( x1 - x0 ) )

sortByangle :: ( Num a , Ord a ) => [ Point a ] -> [ Point a ]
sortByangle (z:xs) = z : sortBy ( \x y -> compAngle x y z ) xs 

findTurn :: ( Num a , Ord a , Eq a ) => Point a -> Point a -> Point a -> Turn
findTurn ( P x0 y0 ) ( P x1 y1 ) ( P x2 y2 )
 | ( y1 - y0 ) * ( x2- x0 ) < ( y2 - y0 ) * ( x1 - x0 ) = L
 | ( y1 - y0 ) * ( x2- x0 ) == ( y2 - y0 ) * ( x1 - x0 ) = S
 | otherwise = R 

findHull :: ( Num a , Ord a  )  => [ Point a ] ->   [ Point a ] -> [ Point a ]
findHull [x]  ( z : ys )  = findHull [ z , x ]  ys  --incase of second point  on line from x to z
findHull xs  [] = xs
findHull ( y : x : xs )  ( z : ys )
  | findTurn x y z == R = findHull (  x : xs )   ( z:ys )
  | findTurn x y z == S = findHull (  x : xs )   ( z:ys )
  | otherwise = findHull ( z : y : x : xs  )   ys


convexHull ::( Num a , Ord a )  => [ Point a ] -> [ Point a ]
convexHull xs = reverse . findHull [ y , x ]  $ ys where
        ( x : y : ys ) = sortByangle . findMinx $ xs


--end of convex hull 

--start of rotating caliper part http://en.wikipedia.org/wiki/Rotating_calipers
--dot product for getting angle

angVectors :: ( Num a , Ord a , Floating a ) => Vector a -> Vector a -> a
angVectors ( V ax ay ) ( V bx by ) = theta where
    dot = ax * bx + ay * by
    a = sqrt $ ax ^ 2 + ay ^ 2
    b = sqrt $ bx ^ 2 + by ^ 2
    theta = acos $ dot / a / b  

--rotate the vector x y by angle t

rotVector :: ( Num a , Ord a , Floating a ) => Vector a -> a -> Vector a
rotVector ( V x y ) t = V ( x * cos t - y * sin t ) ( x * sin t + y * cos t )  

distPoints :: ( Num a , Ord a , Floating a ) => Point a -> Point a -> a 
distPoints ( P x1 y1 ) ( P x2 y2 ) = sqrt $ ( x1 -x2 ) ^ 2 + ( y1 - y2 ) ^ 2 

distVec :: ( Num a , Ord a , Floating a ) => Point a -> Point a -> Point a -> a  
distVec ( P x1 y1 ) ( P x2 y2 ) ( P x0 y0 ) = d / v where 
	d = abs $ ( x2 - x1 ) * ( y1 - y0 ) - ( x1 - x0 ) * ( y2 - y1 ) 
	v = sqrt $ ( x2 -x1 ) ^ 2 + ( y2 - y1 ) ^ 2 


--rotating caliipers 

rotCal :: ( Num a , Ord a , Floating a ) => Array Int ( Point a )  -> a -> [ Int ] -> [ Vector a ] -> a -> Int -> a
rotCal arr ang  [ pa , pb , qa , qb] [ cpa , cpb , cqa , cqb ] area  n
   |2 * ang > pi = area
   | otherwise = rotCal arr ang' [ pa' , pb' , qa' , qb' ] [ cpa' , cpb' , cqa' , cqb' ] area' n where
	P x1 y1 = arr ! pa
	P x2 y2 = arr ! ( mod ( pa + 1 ) n )
	P x3 y3 = arr ! pb
	P x4 y4 = arr ! ( mod ( pb + 1 ) n )
	
	P x5 y5 = arr ! qa 
	P x6 y6 = arr ! ( mod ( qa + 1 ) n )
	P x7 y7 = arr ! qb
	P x8 y8 = arr ! ( mod ( qb + 1 ) n ) 

	t1 = angVectors cpa ( V ( x2 - x1 ) ( y2 - y1 ) )
	t2 = angVectors cpb ( V ( x4 - x3 ) ( y4 - y3 ) )
	t3 = angVectors cqa ( V ( x6 - x5 ) ( y6 - y5 ) )
	t4 = angVectors cqb ( V ( x8 - x7 ) ( y8 - y7 ) )
	t = minimum [ t1 , t2 , t3 , t4 ]
	
        cpa' = rotVector cpa  t
	cpb' = rotVector cpb  t
	cqa' = rotVector cqa  t
	cqb' = rotVector cqb  t

	ang' = ang + t 
	( pa' , pb' , qa' , qb' ) = fN1 [ t1 , t2 , t3 , t4 ] t where 
		fN1 [ t1 , t2 , t3 , t4 ] t 
		   | t == t1 = ( mod ( pa + 1 ) n , pb , qa , qb ) 
		   | t == t2 = ( pa , mod ( pb + 1 ) n , qa , qb )  
		   | t == t3 = ( pa , pb , mod ( qa + 1 ) n , qb )
		   | otherwise = ( pa , pb , qa , mod ( qb + 1 ) n )
	

	
	( length , width ) = fN2 [ t1 , t2 , t3 , t4 ] t where 
		fN2 [ t1 , t2 , t3 , t4 ] t 
		   | t == t1 = ( distVec ( arr ! pa ) ( arr ! pa' )  ( arr ! pb ) , distPoints ( arr ! qa' ) ( arr ! qb' ) )
		   | t == t2 = ( distVec ( arr ! pb ) ( arr ! pb' )  ( arr ! pa ) , distPoints ( arr ! qa' ) ( arr ! qb' ) )
		   | t == t3 = ( distVec ( arr ! qa ) ( arr ! qa' )  ( arr ! qb ) , distPoints ( arr ! pa' ) ( arr ! pb' ) )
		   | otherwise = ( distVec ( arr ! qb ) ( arr ! qb' ) ( arr ! qa ) , distPoints ( arr ! pa' ) ( arr ! pb' ) )
	
	
	area' = min area $ length * width 

solve :: ( Num a , Ord a , Floating a ) => [ Point a ] -> a
solve [] = 0
solve [ p ] = 0
solve [ p1 , p2 ] =  0 
solve [ p1 , p2 , p3 ] = 0  
solve arr =  rotCal arr' 0 [ pa , pb , qa , qb ] [ cpa , cpb , cqa , cqb ] area   n where
	   y1 = minimumBy ( on  compare fN1  ) arr
	   y2 = maximumBy ( on  compare fN1  ) arr
	   x1 = minimumBy ( on  compare fN2  ) arr
	   x2 = maximumBy ( on  compare fN2  ) arr 
	   pa = fromJust . findIndex (  == y1 ) $ arr
	   pb = fromJust . findIndex (  == y2 ) $ arr
	   qa = fromJust . findIndex (  == x1 ) $ arr
	   qb = fromJust . findIndex (  == x2 ) $ arr
	   P x3 y3 = arr' ! pa 
	   P x4 y4 = arr' ! pb
	   P x5 y5 = arr' ! qa 
	   P x6 y6 = arr' ! qb
	   cpa = V 1  0 --crux of problem is finding a vector which is parallel to x axis and pass through pa  
	   cpb = V ( -1 ) 0  
	   cqa = V 0 ( -1 ) 
	   cqb = V 0 1
	   area = abs $ ( y4 - y3 ) * ( x6 - x5 )
	   n = length arr
	   arr' = listArray ( 0 , n ) arr
	   fN1 ( P x y ) = y 
	   fN2 ( P x y ) = x 
 
--end of rotating caliper 



final :: ( Num a , Ord a , Floating a ) => [ Point a ] -> a
final [] = 0
final [ p ] = 0
final [ p1 , p2 ] =  0
final [ p1 , p2 , p3 ] = 0 
final arr = solve . convexHull $ arr
20:1: Error: Eta reduce
Found:
findMinx xs = sortBy (\ x y -> compPoint x y) xs
Why not:
findMinx = sortBy (\ x y -> compPoint x y)
20:24: Warning: Avoid lambda
Found:
\ x y -> compPoint x y
Why not:
compPoint
81:19: Warning: Redundant bracket
Found:
arr ! (mod (pa + 1) n)
Why not:
arr ! mod (pa + 1) n
83:19: Warning: Redundant bracket
Found:
arr ! (mod (pb + 1) n)
Why not:
arr ! mod (pb + 1) n
86:19: Warning: Redundant bracket
Found:
arr ! (mod (qa + 1) n)
Why not:
arr ! mod (qa + 1) n
88:19: Warning: Redundant bracket
Found:
arr ! (mod (qb + 1) n)
Why not:
arr ! mod (qb + 1) n
127:29: Error: Use comparing
Found:
on compare fN1
Why not:
Data.Ord.comparing fN1
127:29: Error: Use comparing
Found:
on compare
Why not:
Data.Ord.comparing
128:29: Error: Use comparing
Found:
on compare fN1
Why not:
Data.Ord.comparing fN1
128:29: Error: Use comparing
Found:
on compare
Why not:
Data.Ord.comparing
129:29: Error: Use comparing
Found:
on compare fN2
Why not:
Data.Ord.comparing fN2
129:29: Error: Use comparing
Found:
on compare
Why not:
Data.Ord.comparing
130:29: Error: Use comparing
Found:
on compare fN2
Why not:
Data.Ord.comparing fN2
130:29: Error: Use comparing
Found:
on compare
Why not:
Data.Ord.comparing