Movatterモバイル変換

{-# LANGUAGE Trustworthy       #-}{-# LANGUAGE BangPatterns      #-}{-# LANGUAGE CPP               #-}{-# LANGUAGE DeriveFoldable    #-}{-# LANGUAGE DeriveFunctor     #-}{-# LANGUAGE DeriveTraversable #-}{-# LANGUAGE MagicHash         #-}{-# LANGUAGE NoImplicitPrelude #-}{-# LANGUAGE UnboxedTuples     #-}moduleGHC.Event.PSQ(-- * Binding TypeElem(..),Key,Prio-- * Priority Search Queue Type,PSQ-- * Query,size,null,lookup-- * Construction,empty,singleton-- * Insertion,unsafeInsertNew-- * Delete/Update,delete,adjust-- * Conversion,toList-- * Min,findMin,deleteMin,minView,atMost)whereimportGHC.Basehiding(Nat,empty)importGHC.Event.UniqueimportGHC.Word(Word64)importGHC.Num(Num(..))importGHC.Real(fromIntegral)importGHC.Types(Int)#include "MachDeps.h"-- TODO (SM): get rid of bang patterns{--- Use macros to define strictness of functions.-- STRICT_x_OF_y denotes a y-ary function strict in the x-th parameter.-- We do not use BangPatterns, because they are not in any standard and we-- want the compilers to be compiled by as many compilers as possible.#define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined-}-------------------------------------------------------------------------------- Types------------------------------------------------------------------------------typePrio=Word64typeNat=WordtypeKey=Unique-- | We store masks as the index of the bit that determines the branching.typeMask=InttypePSQa=IntPSQa-- | @E k p@ binds the key @k@ with the priority @p@.dataElema=E{key::{-# UNPACK#-}!Key,prio::{-# UNPACK#-}!Prio,value::a}-- | A priority search queue with @Int@ keys and priorities of type @p@ and-- values of type @v@. It is strict in keys, priorities and values.dataIntPSQv=Bin{-# UNPACK#-}!Key{-# UNPACK#-}!Prio!v{-# UNPACK#-}!Mask!(IntPSQv)!(IntPSQv)|Tip{-# UNPACK#-}!Key{-# UNPACK#-}!Prio!v|Nil-- bit twiddling----------------(.&.)::Nat->Nat->Nat(.&.)(W#w1)(W#w2)=W#(w1`and#`w2){-# INLINE(.&.)#-}xor::Nat->Nat->Natxor(W#w1)(W#w2)=W#(w1`xor#`w2){-# INLINExor#-}complement::Nat->Natcomplement(W#w)=W#(w`xor#`mb)where#if WORD_SIZE_IN_BITS == 32mb=0xFFFFFFFF###elif WORD_SIZE_IN_BITS == 64mb=0xFFFFFFFFFFFFFFFF###else#error Unhandled value for WORD_SIZE_IN_BITS#endif{-# INLINEcomplement#-}{-# INLINEnatFromInt#-}natFromInt::Int->NatnatFromInt=fromIntegral{-# INLINEintFromNat#-}intFromNat::Nat->IntintFromNat=fromIntegral{-# INLINEzero#-}zero::Key->Mask->Boolzeroim=(natFromInt(asInti)).&.(natFromIntm)==0{-# INLINEnomatch#-}nomatch::Key->Key->Mask->Boolnomatchk1k2m=natFromInt(asIntk1).&.m'/=natFromInt(asIntk2).&.m'wherem'=maskW(natFromIntm){-# INLINEmaskW#-}maskW::Nat->NatmaskWm=complement(m-1)`xor`m{-# INLINEbranchMask#-}branchMask::Key->Key->MaskbranchMaskk1'k2'=intFromNat(highestBitMask(natFromIntk1`xor`natFromIntk2))wherek1=asIntk1'k2=asIntk2'highestBitMask::Nat->NathighestBitMask(W#x)=W#(uncheckedShiftL#1##(word2Int#(WORD_SIZE_IN_BITS##`minusWord#`1##`minusWord#`clz#x))){-# INLINEhighestBitMask#-}-------------------------------------------------------------------------------- Query-------------------------------------------------------------------------------- | /O(1)/ True if the queue is empty.null::IntPSQv->BoolnullNil=Truenull_=False-- | /O(n)/ The number of elements stored in the queue.size::IntPSQv->IntsizeNil=0size(Tip___)=1size(Bin____lr)=1+sizel+sizer-- TODO (SM): benchmark this against a tail-recursive variant-- | /O(min(n,W))/ The priority and value of a given key, or 'Nothing' if the-- key is not bound.lookup::Key->IntPSQv->Maybe(Prio,v)lookupk=gowheregot=casetofNil->NothingTipk'p'x'|k==k'->Just(p',x')|otherwise->NothingBink'p'x'mlr|nomatchkk'm->Nothing|k==k'->Just(p',x')|zerokm->gol|otherwise->gor-- | /O(1)/ The element with the lowest priority.findMin::IntPSQv->Maybe(Elemv)findMint=casetofNil->NothingTipkpx->Just(Ekpx)Binkpx___->Just(Ekpx)--------------------------------------------------------------------------------- Construction-------------------------------------------------------------------------------- | /O(1)/ The empty queue.empty::IntPSQvempty=Nil-- | /O(1)/ Build a queue with one element.singleton::Key->Prio->v->IntPSQvsingleton=Tip-------------------------------------------------------------------------------- Insertion-------------------------------------------------------------------------------- | /O(min(n,W))/ Insert a new key that is *not* present in the priority queue.{-# INLINABLEunsafeInsertNew#-}unsafeInsertNew::Key->Prio->v->IntPSQv->IntPSQvunsafeInsertNewkpx=gowheregot=casetofNil->TipkpxTipk'p'x'|(p,k)<(p',k')->linkkpxk'tNil|otherwise->linkk'p'x'k(Tipkpx)NilBink'p'x'mlr|nomatchkk'm->if(p,k)<(p',k')thenlinkkpxk'tNilelselinkk'p'x'k(Tipkpx)(mergemlr)|otherwise->if(p,k)<(p',k')thenifzerok'mthenBinkpxm(unsafeInsertNewk'p'x'l)relseBinkpxml(unsafeInsertNewk'p'x'r)elseifzerokmthenBink'p'x'm(unsafeInsertNewkpxl)relseBink'p'x'ml(unsafeInsertNewkpxr)-- | Linklink::Key->Prio->v->Key->IntPSQv->IntPSQv->IntPSQvlinkkpxk'k'totherTree|zero(Uniquem)(asIntk')=Binkpxmk'totherTree|otherwise=BinkpxmotherTreek'twherem=branchMaskkk'-------------------------------------------------------------------------------- Delete/Alter-------------------------------------------------------------------------------- | /O(min(n,W))/ Delete a key and its priority and value from the queue. When-- the key is not a member of the queue, the original queue is returned.{-# INLINABLEdelete#-}delete::Key->IntPSQv->IntPSQvdeletek=gowheregot=casetofNil->NilTipk'__|k==k'->Nil|otherwise->tBink'p'x'mlr|nomatchkk'm->t|k==k'->mergemlr|zerokm->binShrinkLk'p'x'm(gol)r|otherwise->binShrinkRk'p'x'ml(gor)-- | /O(min(n,W))/ Delete the binding with the least priority, and return the-- rest of the queue stripped of that binding. In case the queue is empty, the-- empty queue is returned again.{-# INLINEdeleteMin#-}deleteMin::IntPSQv->IntPSQvdeleteMint=caseminViewtofNothing->tJust(_,t')->t'adjust::(Prio->Prio)->Key->PSQa->PSQaadjustfkq=casealtergkqof(_,q')->q'whereg(Just(p,v))=((),Just((fp),v))gNothing=((),Nothing){-# INLINEadjust#-}-- | /O(min(n,W))/ The expression @alter f k queue@ alters the value @x@ at @k@,-- or absence thereof. 'alter' can be used to insert, delete, or update a value-- in a queue. It also allows you to calculate an additional value @b@.{-# INLINEalter#-}alter::(Maybe(Prio,v)->(b,Maybe(Prio,v)))->Key->IntPSQv->(b,IntPSQv)alterf=\kt0->let(t,mbX)=casedeleteViewkt0ofNothing->(t0,Nothing)Just(p,v,t0')->(t0',Just(p,v))incasefmbXof(b,mbX')->(b,maybet(\(p,v)->unsafeInsertNewkpvt)mbX')wheremaybe_g(Justx)=gxmaybedef_Nothing=def-- | Smart constructor for a 'Bin' node whose left subtree could have become-- 'Nil'.{-# INLINEbinShrinkL#-}binShrinkL::Key->Prio->v->Mask->IntPSQv->IntPSQv->IntPSQvbinShrinkLkpxmNilr=caserofNil->Tipkpx;_->BinkpxmNilrbinShrinkLkpxmlr=Binkpxmlr-- | Smart constructor for a 'Bin' node whose right subtree could have become-- 'Nil'.{-# INLINEbinShrinkR#-}binShrinkR::Key->Prio->v->Mask->IntPSQv->IntPSQv->IntPSQvbinShrinkRkpxmlNil=caselofNil->Tipkpx;_->BinkpxmlNilbinShrinkRkpxmlr=Binkpxmlr-------------------------------------------------------------------------------- Lists-------------------------------------------------------------------------------- | /O(n)/ Convert a queue to a list of (key, priority, value) tuples. The-- order of the list is not specified.toList::IntPSQv->[Elemv]toList=go[]wheregoaccNil=accgoacc(Tipk'p'x')=(Ek'p'x'):accgoacc(Bink'p'x'_mlr)=(Ek'p'x'):go(goaccr)l-------------------------------------------------------------------------------- Views-------------------------------------------------------------------------------- | /O(min(n,W))/ Delete a key and its priority and value from the queue. If-- the key was present, the associated priority and value are returned in-- addition to the updated queue.{-# INLINABLEdeleteView#-}deleteView::Key->IntPSQv->Maybe(Prio,v,IntPSQv)deleteViewkt0=casedelFromt0of(#_,Nothing#)->Nothing(#t,Just(p,x)#)->Just(p,x,t)wheredelFromt=casetofNil->(#Nil,Nothing#)Tipk'p'x'|k==k'->(#Nil,Just(p',x')#)|otherwise->(#t,Nothing#)Bink'p'x'mlr|nomatchkk'm->(#t,Nothing#)|k==k'->lett'=mergemlrint'`seq`(#t',Just(p',x')#)|zerokm->casedelFromlof(#l',mbPX#)->lett'=binShrinkLk'p'x'ml'rint'`seq`(#t',mbPX#)|otherwise->casedelFromrof(#r',mbPX#)->lett'=binShrinkRk'p'x'mlr'int'`seq`(#t',mbPX#)-- | /O(min(n,W))/ Retrieve the binding with the least priority, and the-- rest of the queue stripped of that binding.{-# INLINEminView#-}minView::IntPSQv->Maybe(Elemv,IntPSQv)minViewt=casetofNil->NothingTipkpx->Just(Ekpx,Nil)Binkpxmlr->Just(Ekpx,mergemlr)-- | Return a list of elements ordered by key whose priorities are at most @pt@,-- and the rest of the queue stripped of these elements.  The returned list of-- elements can be in any order: no guarantees there.{-# INLINABLEatMost#-}atMost::Prio->IntPSQv->([Elemv],IntPSQv)atMostptt0=go[]t0wheregoacct=casetofNil->(acc,t)Tipkpx|p>pt->(acc,t)|otherwise->((Ekpx):acc,Nil)Binkpxmlr|p>pt->(acc,t)|otherwise->let(acc',l')=goaccl(acc'',r')=goacc'rin((Ekpx):acc'',mergeml'r')-------------------------------------------------------------------------------- Traversal-------------------------------------------------------------------------------- | Internal function that merges two *disjoint* 'IntPSQ's that share the-- same prefix mask.{-# INLINABLEmerge#-}merge::Mask->IntPSQv->IntPSQv->IntPSQvmergemlr=caselofNil->rTiplklplx->caserofNil->lTiprkrprx|(lp,lk)<(rp,rk)->BinlklplxmNilr|otherwise->BinrkrprxmlNilBinrkrprxrmrlrr|(lp,lk)<(rp,rk)->BinlklplxmNilr|otherwise->Binrkrprxml(mergermrlrr)Binlklplxlmlllr->caserofNil->lTiprkrprx|(lp,lk)<(rp,rk)->Binlklplxm(mergelmlllr)r|otherwise->BinrkrprxmlNilBinrkrprxrmrlrr|(lp,lk)<(rp,rk)->Binlklplxm(mergelmlllr)r|otherwise->Binrkrprxml(mergermrlrr)