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
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
|
module T15005 (
OrderCell,
ElementCell,
rawAlgorithm,
rawAlgorithmWithSize
) where
-- Control
import Control.Applicative
import Control.Monad
import Control.Monad.ST
-- Data
import Data.Word
import Data.Bits
import Data.STRef
type RawOrder s o = STRef s (o s)
type RawElement s e = STRef s (e s)
data RawAlgorithm s o e = RawAlgorithm {
newOrder :: ST s (RawOrder s o),
compareElements :: RawElement s e -> RawElement s e -> RawOrder s o -> ST s Ordering,
newMinimum :: RawOrder s o -> ST s (RawElement s e),
newMaximum :: RawOrder s o -> ST s (RawElement s e),
newAfter :: RawElement s e -> RawOrder s o -> ST s (RawElement s e),
newBefore :: RawElement s e -> RawOrder s o -> ST s (RawElement s e),
delete :: RawElement s e -> RawOrder s o -> ST s ()
}
{-FIXME:
If we ever allow users to plug in their own algorithms, we have to flag the
respective function as unsafe and point out that referential transparency is
in danger if the algorithm does not fulfill the specification. This is
because element comparison is presented to the user as a pure function. The
important condition is that for any two elements, compareElements must
always return the same result as long as delete is not called on either
element.
-}
type OrderCell = Cell
type ElementCell = Cell
data Cell s = Cell {
label :: Label,
next :: CellRef s,
prev :: CellRef s
}
type CellRef s = STRef s (Cell s)
newtype Label = Label LabelWord deriving (Eq, Ord)
type LabelWord = Word64
labelWordSize :: Int
labelWordSize = 64
initialBaseLabel :: Label
initialBaseLabel = Label 0
rawAlgorithm :: RawAlgorithm s OrderCell ElementCell
rawAlgorithm = rawAlgorithmWithSize defaultSize
defaultSize :: Int
defaultSize = 63
rawAlgorithmWithSize :: Int -> RawAlgorithm s OrderCell ElementCell
rawAlgorithmWithSize size
| size < 0 || size >= labelWordSize
= error "Data.Order.Algorithm.dietzSleatorAmortizedLogWithSize: \
\Size out of bounds"
| otherwise
= RawAlgorithm {
newOrder = fixST $
\ ref -> newSTRef $ Cell {
label = initialBaseLabel,
next = ref,
prev = ref
},
compareElements = \ ref1 ref2 baseRef -> do
baseCell <- readSTRef baseRef
cell1 <- readSTRef ref1
cell2 <- readSTRef ref2
let offset1 = labelDiff (label cell1)
(label baseCell)
let offset2 = labelDiff (label cell2)
(label baseCell)
return $ compare offset1 offset2,
newMinimum = newAfterCell,
newMaximum = newBeforeCell,
newAfter = const . newAfterCell,
newBefore = const . newBeforeCell,
delete = \ ref _ -> do
cell <- readSTRef ref
modifySTRef
(prev cell)
(\ prevCell -> prevCell {
next = next cell
})
modifySTRef
(next cell)
(\ nextCell -> nextCell {
prev = prev cell
})
} where
noOfLabels :: LabelWord
noOfLabels = shiftL 1 size
labelMask :: LabelWord
labelMask = pred noOfLabels
toLabel :: LabelWord -> Label
toLabel = Label . (.&. labelMask)
labelSum :: Label -> Label -> Label
labelSum (Label word1) (Label word2) = toLabel (word1 + word2)
labelDiff :: Label -> Label -> Label
labelDiff (Label word1) (Label word2) = toLabel (word1 - word2)
labelDistance :: Label -> Label -> LabelWord
labelDistance lbl1 lbl2 = case labelDiff lbl1 lbl2 of
Label word | word == 0 -> noOfLabels
| otherwise -> word
newAfterCell :: CellRef s -> ST s (CellRef s)
newAfterCell ref = do
relabel ref
lbl <- label <$> readSTRef ref
nextRef <- next <$> readSTRef ref
nextLbl <- label <$> readSTRef nextRef
newRef <- newSTRef $ Cell {
label = labelSum lbl (Label (labelDistance nextLbl lbl `div` 2)),
next = nextRef,
prev = ref
}
modifySTRef ref (\ cell -> cell { next = newRef })
modifySTRef nextRef (\ nextCell -> nextCell { prev = newRef })
return newRef
relabel :: CellRef s -> ST s ()
relabel startRef = do
startCell <- readSTRef startRef
let delimSearch ref gapCount = do
cell <- readSTRef ref
let gapSum = labelDistance (label cell) (label startCell)
if gapSum <= gapCount ^ 2
then if ref == startRef
then error "Data.Order.Algorithm.\
\dietzSleatorAmortizedLogWithSize: \
\Order full"
else delimSearch (next cell) (succ gapCount)
else return (ref, gapSum, gapCount)
(delimRef, gapSum, gapCount) <- delimSearch (next startCell) 1
let smallGap = gapSum `div` gapCount
let largeGapCount = gapSum `mod` gapCount
let changeLabels ref ix = when (ref /= delimRef) $ do
cell <- readSTRef ref
let lbl = labelSum
(label startCell)
(Label (ix * smallGap + min largeGapCount ix))
writeSTRef ref (cell { label = lbl })
changeLabels (next cell) (succ ix)
changeLabels (next startCell) 1
{-FIXME:
We allow the number of cells to be larger than the square root of the
number of possible labels as long as we find a sparse part in our circle
of cells (since our order full condition is only true if the complete
circle is congested). This should not influence correctness and probably
also not time complexity, but we should check this more thoroughly.
-}
{-FIXME:
We arrange the large and small gaps differently from Dietz and Sleator
by putting all the large gaps at the beginning instead of distributing
them over the relabeled area. However, this should not influence time
complexity, as the complexity proof seems to only rely on the fact that
gap sizes differ by at most 1. We should check this more thoroughly
though.
-}
newBeforeCell :: CellRef s -> ST s (CellRef s)
newBeforeCell ref = do
cell <- readSTRef ref
newAfterCell (prev cell)
|
