No title

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
159
160
161
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ViewPatterns #-}

import           Control.Comonad
import           Control.DeepSeq
import           Control.Lens
import           Control.Monad
import           Control.Monad.Tardis
import           Criterion.Main
import           Data.List.PointedList (PointedList)
import qualified Data.List.PointedList as PE
import           Data.Maybe
import           Data.Vector ((!),Vector)
import qualified Data.Vector as V
import           System.Random
import qualified Data.Array as A

instance Comonad PointedList where
    extend  = PE.contextMap
    extract = PE._focus

water_comonad :: [Int] -> Int
water_comonad = view _2 . wfix . fmap go . fromMaybe (PE.singleton 0) . PE.fromList
  where
    go height context = (lMax, total, rMax)
      where
        get f = maybe (height, 0, height) PE._focus $ f context
        (prevLMax,         _,        _) = get PE.previous
        (_       , prevTotal, prevRMax) = get PE.next
        lMax = max height prevLMax
        rMax = max height prevRMax
        !total = prevTotal + min lMax rMax - height

water_tardis :: [Int] -> Int
water_tardis = flip evalTardis (minBound, minBound) . foldM go 0
  where
    go total height = do
        modifyForwards $ max height
        leftmax <- getPast
        rightmax <- getFuture
        modifyBackwards $ max height
        return $ total + min leftmax rightmax - height

water_onepass :: Vector Int -> Int
water_onepass land = go 0 0 (V.length land - 1) 0 0 where
  go !volume left right
     (extend left -> leftMax)
     (extend right -> rightMax)
    | left < right =
      if leftMax >= rightMax
         then go (volume + rightMax - land!right)
                 left (right - 1) leftMax rightMax
         else go (volume + leftMax - land!left)
                 (left +  1) right leftMax rightMax
    | otherwise = volume
  extend i d = if x > d then x else d
    where x= land!i

water_loeb :: Vector Int -> Int
water_loeb = V.sum . V.map (view _3) . loeb . V.imap cell where
  cell i x xs
    | i == 0               = edge _2
    | i == V.length xs - 1 = edge _1
    | otherwise            = col i x xs
    where edge ln = set l (view l (col i x xs)) (x,x,0)
            where l r = cloneLens ln r
  col i x xs = (l,r,min l r - x)
    where l = neighbor _1 (-)
          r = neighbor _2 (+)
          neighbor l o = max x (view l (xs ! (i `o` 1)))

water_loeb' :: Vector Int -> Int
water_loeb' = V.sum . V.map (view _3) . loeb' . V.imap cell where
  cell i x xs
    | i == 0               = edge _2
    | i == V.length xs - 1 = edge _1
    | otherwise            = col i x xs
    where edge ln = set l (view l (col i x xs)) (x,x,0)
            where l r = cloneLens ln r
  col i x xs = (l,r,min l r - x)
    where l = neighbor _1 (-)
          r = neighbor _2 (+)
          neighbor l o = max x (view l (xs ! (i `o` 1)))

water :: [Int] -> Int
water h =
  sum (zipWith (-)
               (zipWith min
                        (scanl1 max h)
                        (scanr1 max h))
               h)

water_array :: A.Array Int Int -> Int
water_array arr = go 0 minB maxB where
    (minB,maxB) = A.bounds arr

    go !acc lpos rpos
        | lpos >= rpos             = acc
        | leftHeight < rightHeight = segment leftHeight    1  acc lpos contLeft
        | otherwise                = segment rightHeight (-1) acc rpos contRight
        where
            leftHeight          = arr A.! lpos
            rightHeight         = arr A.! rpos
            contLeft  acc' pos' = go acc' pos' rpos
            contRight acc' pos' = go acc' lpos pos'

    segment limit move !acc' !pos cont
        | delta <= 0 = cont acc' pos'
        | otherwise  = segment limit move (acc' + delta) pos' cont
        where
            delta = limit - arr A.! pos'
            pos'  = pos + move

water_vector:: Vector Int -> Int
water_vector arr = go 0 minB maxB where
    (minB,maxB) = (0,10000-1)

    go !acc lpos rpos
        | lpos >= rpos             = acc
        | leftHeight < rightHeight = segment leftHeight    1  acc lpos contLeft
        | otherwise                = segment rightHeight (-1) acc rpos contRight
        where
            leftHeight          = arr ! lpos
            rightHeight         = arr ! rpos
            contLeft  acc' pos' = go acc' pos' rpos
            contRight acc' pos' = go acc' lpos pos'

    segment limit move !acc' !pos cont
        | delta <= 0 = cont acc' pos'
        | otherwise  = segment limit move (acc' + delta) pos' cont
        where
            delta = limit - arr ! pos'
            pos'  = pos + move

loeb :: Functor f => f (f b -> b) -> f b
loeb x = xs
  where xs = fmap ($ xs) x

loeb' :: Functor f => f (f b -> b) -> f b
loeb' x = xs
  where xs = fmap ($ xs) x

main = do
  let g = mkStdGen 0
      xs10000 = take 10000 $ randomRs (0,10000) g
      vs10000 = V.fromList xs10000
      as10000 = A.listArray (1,10000) xs10000
  let !() = deepseq xs10000 ()
      !() = deepseq vs10000 ()
      !() = deepseq as10000 ()
  defaultMain
    [bgroup "water" [bench "10000" $ whnf water xs10000]
    ,bgroup "water_loeb" [bench "10000" $ whnf water_loeb vs10000]
    ,bgroup "water_loeb'" [bench "10000" $ whnf water_loeb' vs10000]
    ,bgroup "water_onepass" [bench "10000" $ whnf water_onepass vs10000]
    ,bgroup "water_tardis" [bench "10000" $ whnf water_tardis xs10000]
    ,bgroup "water_array" [bench "10000" $ whnf water_array as10000]
    ,bgroup "water_vector" [bench "10000" $ whnf water_vector vs10000]
    -- This is too slow.
    -- ,bgroup "water_comonad" [bench "10000" $ whnf water_comonad xs10000]
   ]
23:1: Warning: Use camelCase
Found:
water_comonad = ...
Why not:
waterComonad = ...
68:11: Warning: Reduce duplication
Found:
l = neighbor _1 (-)
r = neighbor _2 (+)
neighbor l o = max x (view l (xs ! (i `o` 1)))
Why not:
Combine with /tmp/95687.hs:81:11
35:1: Warning: Use camelCase
Found:
water_tardis = ...
Why not:
waterTardis = ...
45:1: Warning: Use camelCase
Found:
water_onepass land = ...
Why not:
waterOnepass land = ...
60:1: Warning: Use camelCase
Found:
water_loeb = ...
Why not:
waterLoeb = ...
66:19: Error: Eta reduce
Found:
l r = cloneLens ln r
Why not:
l = cloneLens ln
73:1: Warning: Use camelCase
Found:
water_loeb' = ...
Why not:
waterLoeb' = ...
79:19: Error: Eta reduce
Found:
l r = cloneLens ln r
Why not:
l = cloneLens ln
94:1: Warning: Use camelCase
Found:
water_array arr = ...
Why not:
waterArray arr = ...
105:13: Error: Eta reduce
Found:
contRight acc' pos' = go acc' lpos pos'
Why not:
contRight acc' = go acc' lpos
115:1: Warning: Use camelCase
Found:
water_vector arr = ...
Why not:
waterVector arr = ...
126:13: Error: Eta reduce
Found:
contRight acc' pos' = go acc' lpos pos'
Why not:
contRight acc' = go acc' lpos
148:7: Error: Redundant bang pattern
Found:
!()
Why not:
()
149:7: Error: Redundant bang pattern
Found:
!()
Why not:
()
150:7: Error: Redundant bang pattern
Found:
!()
Why not:
()