module Data.FDList where
import qualified Data.IntMap as IM
type Ref = Int
data Node a = Node{node_val :: a,
node_left :: Ref,
node_right :: Ref}
data DList a = DList{dl_counter :: Ref,
dl_current :: Ref,
dl_mem :: IM.IntMap (Node a)}
empty :: DList a
empty = DList{dl_counter = 1, dl_current = 0, dl_mem = IM.empty}
well_formed :: DList a -> Bool
well_formed dl | IM.null (dl_mem dl) = dl_current dl == 0
well_formed dl = IM.member (dl_current dl) (dl_mem dl)
is_empty :: DList a -> Bool
is_empty dl = IM.null (dl_mem dl)
get_curr_node :: DList a -> Node a
get_curr_node DList{dl_current=curr,dl_mem=mem} =
maybe (error "not well-formed") id $ IM.lookup curr mem
insert_right :: a -> DList a -> DList a
insert_right x dl | is_empty dl =
let ref = dl_counter dl
node = Node{node_val = x, node_left = ref, node_right = ref}
in DList{dl_counter = succ ref,
dl_current = ref,
dl_mem = IM.insert ref node (dl_mem dl)}
insert_right x dl@DList{dl_counter = ref, dl_current = curr, dl_mem = mem} =
DList{dl_counter = succ ref, dl_current = ref,
dl_mem = IM.insert ref new_node $
IM.insert next next_node' $
(if next == curr then mem else IM.insert curr curr_node' mem)}
where
curr_node = get_curr_node dl
curr_node'= curr_node{node_right = ref}
next = node_right curr_node
next_node = if next == curr then curr_node'
else maybe (error "ill-formed DList") id $ IM.lookup next mem
new_node = Node{node_val = x, node_left = curr, node_right = next}
next_node'= next_node{node_left = ref}
delete :: DList a -> DList a
delete dl@DList{dl_current = curr, dl_mem = mem_old} =
case () of
_ | notexist l && notexist r -> empty
_ | r == 0 ->
dl{dl_current = l, dl_mem = upd l (\x -> x{node_right=r}) mem}
_ | r == curr ->
dl{dl_current = l, dl_mem = upd l (\x -> x{node_right=l}) mem}
_ | l == 0 ->
dl{dl_current = r, dl_mem = upd r (\x -> x{node_left=l}) mem}
_ | l == curr ->
dl{dl_current = r, dl_mem = upd r (\x -> x{node_left=r}) mem}
_ | l == r ->
dl{dl_current = r, dl_mem = upd r (\x -> x{node_left=r,
node_right=r}) mem}
_ ->
dl{dl_current = r, dl_mem = upd r (\x -> x{node_left=l}) .
upd l (\x -> x{node_right=r}) $ mem}
where
(Just curr_node, mem) = IM.updateLookupWithKey (\_ _ -> Nothing) curr mem_old
l = node_left curr_node
r = node_right curr_node
notexist x = x == 0 || x == curr
upd ref f mem = IM.adjust f ref mem
get_curr :: DList a -> a
get_curr = node_val . get_curr_node
move_right :: DList a -> Maybe (DList a)
move_right dl = if next == 0 then Nothing else Just (dl{dl_current=next})
where
next = node_right $ get_curr_node dl
move_right' :: DList a -> DList a
move_right' dl = maybe dl id $ move_right dl
move_left :: DList a -> Maybe (DList a)
move_left dl = if next == 0 then Nothing else Just (dl{dl_current=next})
where
next = node_left $ get_curr_node dl
move_left' :: DList a -> DList a
move_left' dl = maybe dl id $ move_left dl
fromList :: [a] -> DList a
fromList = foldl (flip insert_right) empty
takeDL :: Int -> DList a -> [a]
takeDL 0 _ = []
takeDL n dl | is_empty dl = []
takeDL n dl = get_curr dl : (maybe [] (takeDL (pred n)) $ move_right dl)
takeDLrev :: Int -> DList a -> [a]
takeDLrev 0 _ = []
takeDLrev n dl | is_empty dl = []
takeDLrev n dl = get_curr dl : (maybe [] (takeDLrev (pred n)) $ move_left dl)
update :: a -> DList a -> DList a
update x dl@(DList{dl_current = curr, dl_mem = mem}) =
dl{dl_mem = IM.insert curr (curr_node{node_val = x}) mem}
where
curr_node = get_curr_node dl
toList :: DList a -> [a]
toList dl | is_empty dl = []
toList dl = get_curr dl : collect (dl_current dl) (move_right dl)
where
collect ref0 Nothing = []
collect ref0 (Just DList{dl_current = curr}) | curr == ref0 = []
collect ref0 (Just dl) = get_curr dl : collect ref0 (move_right dl)
test1l = insert_right 1 $ empty
test1l_r = takeDL 5 test1l
test1l_l = takeDLrev 5 test1l
test1l_c = toList test1l
test2l = insert_right 2 $ test1l
test2l_r = takeDL 5 test2l
test2l_l = takeDLrev 5 test2l
test2l_l'= takeDLrev 5 (move_left' test2l)
test2l_c = toList test2l
test3l = insert_right 3 $ test2l
test3l_r = takeDL 7 test3l
test3l_l = takeDLrev 7 test3l
test3l_l'= takeDLrev 7 (move_left' test3l)
test3l_c = toList (move_right' test3l)
test31l = delete test3l
test31l_r = takeDL 7 test31l
test31l_l = takeDLrev 7 test31l
test31l_c = toList test31l
test32l = delete test31l
test32l_r = takeDL 5 test32l
test32l_l = takeDLrev 5 test32l
test32l_c = toList test32l
test33l = delete test32l
test33l_r = takeDL 5 test33l
testl = fromList [1..5]
testl_r = takeDL 11 testl
testl_l = takeDLrev 11 testl
testl_c = toList testl
testl1 = update (1) testl
testl1_r = takeDL 11 testl1
testl1_c = toList testl1
testl2 = update (2) . move_right' . move_right' $ testl1
testl2_r = takeDL 11 testl2
testl2_l = takeDLrev 11 testl2
testl2_c = toList testl2
testl3 = update (2) . move_right' . move_right' $ testl
testl3_r = takeDL 11 testl3
testl3_c = toList testl3