-- | Haskell98---- <http://okmij.org/ftp/Algorithms.html#pure-cyclic-list>---- Pure functional, mutation-free, constant-time-access double-linked-- lists---- Note that insertions, deletions, lookups have-- a worst-case complexity of O(min(n,W)), where W is either 32 or 64-- (depending on the paltform). That means the access time is bounded-- by a small constant (32 or 64). ------ /Pure functional, mutation-free, efficient double-linked lists/-- -- It is always an interesting challenge to write a pure functional and efficient implementation of-- an imperative algorithm destructively operating a data structure. The functional implementation-- has a significant benefit of equational reasoning and modularity. We can comprehend the algorithm-- without keeping the implicit global state in mind. The mutation-free, functional realization has-- practical benefits: the ease of adding checkpointing, undo and redo. The absence of mutations-- makes the code multi-threading-safe and helps in porting to distributed or non-shared-memory-- parallel architectures. On the other hand, an imperative implementation has the advantage of-- optimality: mutating a component in a complex data structure is a constant-time operation, at-- least on conventional architectures. Imperative code makes sharing explicit, and so permits-- efficient implementation of cyclic data structures.-- -- We show a simple example of achieving all the benefits of an imperative data structure ---- including sharing and the efficiency of updates -- in a pure functional program. Our data-- structure is a doubly-linked, possibly cyclic list, with the standard operations of adding,-- deleting and updating elements; traversing the list in both directions; iterating over the list,-- with cycle detection. The code:-- -- □ uniformly handles both cyclic and terminated lists;-- □ does not rebuild the whole list on updates;-- □ updates the value in the current node in time bound by a small constant;-- □ does not use or mention any monads;-- □ does not use any IORef, STRef, TVars, or any other destructive updates;-- □ permits the logging, undoing and redoing of updates, checkpointing;-- □ easily generalizes to two-dimensional meshes.-- -- The algorithm is essentially imperative, thus permitting identity checking and in-place-- `updates', but implemented purely functionally. Although the code uses many local, type safe-- `heaps', there is emphatically no global heap and no global state.-- -- Version: The current version is 1.2, Jan 7, 2009.---- References---- Haskell-Cafe discussion ``Updating doubly linked lists''. January 2009--moduleData.FDListwhereimportqualifiedData.IntMapasIM-- | Representation of the double-linked listtypeRef=Int-- positive, we shall treat 0 speciallydataNodea=Node{node_val::a,node_left::Ref,node_right::Ref}-- | Because DList contains the `pointer' to the current element, DList-- is also a ZipperdataDLista=DList{dl_counter::Ref,-- to generate new Refsdl_current::Ref,-- current nodedl_mem::IM.IntMap(Nodea)}-- main `memory'-- | Operations on the DList aempty::DListaempty=DList{dl_counter=1,dl_current=0,dl_mem=IM.empty}-- | In a well-formed list, dl_current must point to a valid node-- All operations below preserve well-formednesswell_formed::DLista->Boolwell_formeddl|IM.null(dl_memdl)=dl_currentdl==0well_formeddl=IM.member(dl_currentdl)(dl_memdl)is_empty::DLista->Boolis_emptydl=IM.null(dl_memdl)-- | auxiliary functionget_curr_node::DLista->Nodeaget_curr_nodeDList{dl_current=curr,dl_mem=mem}=maybe(error"not well-formed")id$IM.lookupcurrmem-- | The insert operation below makes a cyclic list-- The other operations don't care-- Insert to the right of the current element, if any-- Return the DL where the inserted node is the current oneinsert_right::a->DLista->DListainsert_rightxdl|is_emptydl=letref=dl_counterdl-- the following makes the list cyclicnode=Node{node_val=x,node_left=ref,node_right=ref}inDList{dl_counter=succref,dl_current=ref,dl_mem=IM.insertrefnode(dl_memdl)}insert_rightxdl@DList{dl_counter=ref,dl_current=curr,dl_mem=mem}=DList{dl_counter=succref,dl_current=ref,dl_mem=IM.insertrefnew_node$IM.insertnextnext_node'$(ifnext==currthenmemelseIM.insertcurrcurr_node'mem)}wherecurr_node=get_curr_nodedlcurr_node'=curr_node{node_right=ref}next=node_rightcurr_nodenext_node=ifnext==currthencurr_node'elsemaybe(error"ill-formed DList")id$IM.lookupnextmemnew_node=Node{node_val=x,node_left=curr,node_right=next}next_node'=next_node{node_left=ref}-- | Delete the current element from a non-empty list-- We can handle both cyclic and terminated lists-- The right node becomes the current node.-- If the right node does not exists, the left node becomes currentdelete::DLista->DListadeletedl@DList{dl_current=curr,dl_mem=mem_old}=case()of_|notexistl&&notexistr->empty_|r==0->dl{dl_current=l,dl_mem=updl(\x->x{node_right=r})mem}_|r==curr->-- it was a cycle on the rightdl{dl_current=l,dl_mem=updl(\x->x{node_right=l})mem}_|l==0->dl{dl_current=r,dl_mem=updr(\x->x{node_left=l})mem}_|l==curr->dl{dl_current=r,dl_mem=updr(\x->x{node_left=r})mem}_|l==r->dl{dl_current=r,dl_mem=updr(\x->x{node_left=r,node_right=r})mem}_->dl{dl_current=r,dl_mem=updr(\x->x{node_left=l}).updl(\x->x{node_right=r})$mem}where(Justcurr_node,mem)=IM.updateLookupWithKey(\__->Nothing)currmem_oldl=node_leftcurr_noder=node_rightcurr_nodenotexistx=x==0||x==currupdreffmem=IM.adjustfrefmemget_curr::DLista->aget_curr=node_val.get_curr_nodemove_right::DLista->Maybe(DLista)move_rightdl=ifnext==0thenNothingelseJust(dl{dl_current=next})wherenext=node_right$get_curr_nodedl-- | If no right, just stay inplacemove_right'::DLista->DListamove_right'dl=maybedlid$move_rightdlmove_left::DLista->Maybe(DLista)move_leftdl=ifnext==0thenNothingelseJust(dl{dl_current=next})wherenext=node_left$get_curr_nodedl-- | If no left, just stay inplacemove_left'::DLista->DListamove_left'dl=maybedlid$move_leftdlfromList::[a]->DListafromList=foldl(flipinsert_right)empty-- | The following does not anticipate cycles (deliberately)takeDL::Int->DLista->[a]takeDL0_=[]takeDLndl|is_emptydl=[]takeDLndl=get_currdl:(maybe[](takeDL(predn))$move_rightdl)-- | Reverse taking: we move lefttakeDLrev::Int->DLista->[a]takeDLrev0_=[]takeDLrevndl|is_emptydl=[]takeDLrevndl=get_currdl:(maybe[](takeDLrev(predn))$move_leftdl)-- | Update the current node `inplace'update::a->DLista->DListaupdatexdl@(DList{dl_current=curr,dl_mem=mem})=dl{dl_mem=IM.insertcurr(curr_node{node_val=x})mem}wherecurr_node=get_curr_nodedl-- | This one watches for a cycle and terminates when it detects onetoList::DLista->[a]toListdl|is_emptydl=[]toListdl=get_currdl:collect(dl_currentdl)(move_rightdl)wherecollectref0Nothing=[]collectref0(JustDList{dl_current=curr})|curr==ref0=[]collectref0(Justdl)=get_currdl:collectref0(move_rightdl)-- Teststest1l=insert_right1$emptytest1l_r=takeDL5test1l-- [1,1,1,1,1]test1l_l=takeDLrev5test1l-- [1,1,1,1,1]test1l_c=toListtest1l-- [1]test2l=insert_right2$test1ltest2l_r=takeDL5test2l-- [2,1,2,1,2]test2l_l=takeDLrev5test2l-- [2,1,2,1,2]test2l_l'=takeDLrev5(move_left'test2l)-- [1,2,1,2,1]test2l_c=toListtest2l-- [2,1]test3l=insert_right3$test2ltest3l_r=takeDL7test3l-- [3,1,2,3,1,2,3]test3l_l=takeDLrev7test3l-- [3,2,1,3,2,1,3]test3l_l'=takeDLrev7(move_left'test3l)-- [2,1,3,2,1,3,2]test3l_c=toList(move_right'test3l)-- [1,2,3]test31l=deletetest3ltest31l_r=takeDL7test31l-- [1,2,1,2,1,2,1]test31l_l=takeDLrev7test31l-- [1,2,1,2,1,2,1]test31l_c=toListtest31l-- [1,2]test32l=deletetest31ltest32l_r=takeDL5test32l-- [2,2,2,2,2]test32l_l=takeDLrev5test32l-- [2,2,2,2,2]test32l_c=toListtest32l-- [2]test33l=deletetest32ltest33l_r=takeDL5test33l-- []testl=fromList[1..5]testl_r=takeDL11testl-- [5,1,2,3,4,5,1,2,3,4,5]testl_l=takeDLrev11testl-- [5,4,3,2,1,5,4,3,2,1,5]testl_c=toListtestl-- [5,1,2,3,4]testl1=update(-1)testltestl1_r=takeDL11testl1-- [-1,1,2,3,4,-1,1,2,3,4,-1]testl1_c=toListtestl1-- [-1,1,2,3,4]testl2=update(-2).move_right'.move_right'$testl1testl2_r=takeDL11testl2-- [-2,3,4,-1,1,-2,3,4,-1,1,-2]testl2_l=takeDLrev11testl2-- [-2,1,-1,4,3,-2,1,-1,4,3,-2]testl2_c=toListtestl2-- [-2,3,4,-1,1]-- | Old testl is still available: there are no destructive updatestestl3=update(-2).move_right'.move_right'$testltestl3_r=takeDL11testl3-- [-2,3,4,5,1,-2,3,4,5,1,-2]testl3_c=toListtestl3-- [-2,3,4,5,1]