aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

Another update from ingydotnet^djgoku

Browse source
This commit is contained in:
Ingy döt Net 2015-11-18 06:14:39 +00:00
parent 91df62d461
commit 948b86eafa
7604 changed files with 108452 additions and 22726 deletions
Download patch file Download diff file Expand all files Collapse all files

103
Task/Priority-queue/F-Sharp/priority-queue-1.fs Normal file
View file

@ -0,0 +1,103 @@
[<RequireQualifiedAccess>]
module PriorityQ =
// type 'a treeElement = Element of uint32 * 'a
type 'a treeElement = struct val k:uint32 val v:'a new(k,v) = { k=k;v=v } end
type 'a tree = Node of uint32 * 'a treeElement * 'a tree list
type 'a heap = 'a tree list
[<CompilationRepresentation(CompilationRepresentationFlags.UseNullAsTrueValue)>]
[<NoEquality; NoComparison>]
type 'a outerheap = | HeapEmpty | HeapNotEmpty of 'a treeElement * 'a heap
let empty = HeapEmpty
let isEmpty = function | HeapEmpty -> true | _ -> false
let inline private rank (Node(r,_,_)) = r
let inline private root (Node(_,x,_)) = x
exception Empty_Heap
let peekMin = function | HeapEmpty -> None
| HeapNotEmpty(min, _) -> Some (min.k, min.v)
let rec private findMin heap =
match heap with | [] -> raise Empty_Heap //guarded so should never happen
| [node] -> root node,[]
| topnode::heap' ->
let min,subheap = findMin heap' in let rtn = root topnode
match subheap with
| [] -> if rtn.k > min.k then min,[] else rtn,[]
| minnode::heap'' ->
let rmn = root minnode
if rtn.k <= rmn.k then rtn,heap
else rmn,minnode::topnode::heap''
let private mergeTree (Node(r,kv1,ts1) as tree1) (Node (_,kv2,ts2) as tree2) =
if kv1.k > kv2.k then Node(r+1u,kv2,tree1::ts2)
else Node(r+1u,kv1,tree2::ts1)
let rec private insTree (newnode: 'a tree) heap =
match heap with
| [] -> [newnode]
| topnode::heap' -> if (rank newnode) < (rank topnode) then newnode::heap
else insTree (mergeTree newnode topnode) heap'
let push k v = let kv = treeElement(k,v) in let nn = Node(0u,kv,[])
function | HeapEmpty -> HeapNotEmpty(kv,[nn])
| HeapNotEmpty(min,heap) -> let nmin = if k > min.k then min else kv
HeapNotEmpty(nmin,insTree nn heap)
let rec private merge' heap1 heap2 = //doesn't guaranty minimum tree node as head!!!
match heap1,heap2 with
| _,[] -> heap1
| [],_ -> heap2
| topheap1::heap1',topheap2::heap2' ->
match compare (rank topheap1) (rank topheap2) with
| -1 -> topheap1::merge' heap1' heap2
| 1 -> topheap2::merge' heap1 heap2'
| _ -> insTree (mergeTree topheap1 topheap2) (merge' heap1' heap2')
let merge oheap1 oheap2 = match oheap1,oheap2 with
| _,HeapEmpty -> oheap1
| HeapEmpty,_ -> oheap2
| HeapNotEmpty(min1,heap1),HeapNotEmpty(min2,heap2) ->
let min = if min1.k > min2.k then min2 else min1
HeapNotEmpty(min,merge' heap1 heap2)
let rec private removeMinTree = function
| [] -> raise Empty_Heap // will never happen as already guarded
| [node] -> node,[]
| t::ts -> let t',ts' = removeMinTree ts
if (root t).k <= (root t').k then t,ts else t',t::ts'
let deleteMin =
function | HeapEmpty -> HeapEmpty
| HeapNotEmpty(_,heap) ->
match heap with
| [] -> HeapEmpty // should never occur: non empty heap with no elements
| [Node(_,_,heap')] -> match heap' with
| [] -> HeapEmpty
| _ -> let min,_ = findMin heap'
HeapNotEmpty(min,heap')
| _::_ -> let Node(_,_,ts1),ts2 = removeMinTree heap
let nheap = merge' (List.rev ts1) ts2 in let min,_ = findMin nheap
HeapNotEmpty(min,nheap)
let replaceMin k v pq = push k v (deleteMin pq)
let fromSeq sq = Seq.fold (fun pq (k, v) -> push k v pq) empty sq
let popMin pq = match peekMin pq with
| None -> None
| Some(kv) -> Some(kv, deleteMin pq)
let toSeq pq = Seq.unfold popMin pq
let sort sq = sq |> fromSeq |> toSeq
let adjust f pq = pq |> toSeq |> Seq.map (fun (k, v) -> f k v) |> fromSeq

133
Task/Priority-queue/F-Sharp/priority-queue-2.fs Normal file
View file

@ -0,0 +1,133 @@
[<RequireQualifiedAccess>]
module PriorityQ =
type HeapEntry<'V> = struct val k:uint32 val v:'V new(k,v) = {k=k;v=v} end
[<CompilationRepresentation(CompilationRepresentationFlags.UseNullAsTrueValue)>]
[<NoEquality; NoComparison>]
type PQ<'V> =
| Mt
| Br of HeapEntry<'V> * PQ<'V> * PQ<'V>
let empty = Mt
let isEmpty = function | Mt -> true
| _ -> false
// Return number of elements in the priority queue.
// /O(log(n)^2)/
let rec size = function
| Mt -> 0
| Br(_, ll, rr) ->
let n = size rr
// rest n p q, where n = size ll, and size ll - size rr = 0 or 1
// returns 1 + size ll - size rr.
let rec rest n pl pr =
match pl with
| Mt -> 1
| Br(_, pll, plr) ->
match pr with
| Mt -> 2
| Br(_, prl, prr) ->
let nm1 = n - 1 in let d = nm1 >>> 1
if (nm1 &&& 1) = 0
then rest d pll prl // subtree sizes: (d or d+1), d; d, d
else rest d plr prr // subtree sizes: d+1, (d or d+1); d+1, d
2 * n + rest n ll rr
let peekMin = function | Br(kv, _, _) -> Some(kv.k, kv.v)
| _ -> None
let rec push wk wv =
function | Mt -> Br(HeapEntry(wk, wv), Mt, Mt)
| Br(vkv, ll, rr) ->
if wk <= vkv.k then
Br(HeapEntry(wk, wv), push vkv.k vkv.v rr, ll)
else Br(vkv, push wk wv rr, ll)
let inline private siftdown wk wv pql pqr =
let rec sift pl pr =
match pl with
| Mt -> Br(HeapEntry(wk, wv), Mt, Mt)
| Br(vkvl, pll, plr) ->
match pr with
| Mt -> if wk <= vkvl.k then Br(HeapEntry(wk, wv), pl, Mt)
else Br(vkvl, Br(HeapEntry(wk, wv), Mt, Mt), Mt)
| Br(vkvr, prl, prr) ->
if wk <= vkvl.k && wk <= vkvr.k then Br(HeapEntry(wk, wv), pl, pr)
elif vkvl.k <= vkvr.k then Br(vkvl, sift pll plr, pr)
else Br(vkvr, pl, sift prl prr)
sift pql pqr
let replaceMin wk wv = function | Mt -> Mt
| Br(_, ll, rr) -> siftdown wk wv ll rr
let deleteMin = function
| Mt -> Mt
| Br(_, ll, Mt) -> ll
| Br(vkv, ll, rr) ->
let rec leftrem = function | Mt -> vkv, Mt // should never happen
| Br(kvd, Mt, _) -> kvd, Mt
| Br(vkv, Br(kvd, _, _), Mt) ->
kvd, Br(vkv, Mt, Mt)
| Br(vkv, pl, pr) -> let kvd, pqd = leftrem pl
kvd, Br(vkv, pr, pqd)
let (kvd, pqd) = leftrem ll
siftdown kvd.k kvd.v rr pqd;
let adjust f pq =
let rec adj = function
| Mt -> Mt
| Br(vkv, ll, rr) -> let nk, nv = f vkv.k vkv.v
siftdown nk nv (adj ll) (adj rr)
adj pq
let fromSeq sq =
if Seq.isEmpty sq then Mt
else let nmrtr = sq.GetEnumerator()
let rec build lvl = if lvl = 0 || not (nmrtr.MoveNext()) then Mt
else let ck, cv = nmrtr.Current
let lft = lvl >>> 1
let rght = (lvl - 1) >>> 1
siftdown ck cv (build lft) (build rght)
build (sq |> Seq.length)
let merge (pq1:PQ<_>) (pq2:PQ<_>) = // merges without using a sequence
match pq1 with
| Mt -> pq2
| _ ->
match pq2 with
| Mt -> pq1
| _ ->
let rec zipper lvl pq rest =
if lvl = 0 then Mt, pq, rest else
let lft = lvl >>> 1 in let rght = (lvl - 1) >>> 1
match pq with
| Mt ->
match rest with
| [] | Mt :: _ -> Mt, pq, [] // Mt in list never happens
| Br(kv, ll, Mt) :: tl ->
let pl, pql, rstl = zipper lft ll tl
let pr, pqr, rstr = zipper rght pql rstl
siftdown kv.k kv.v pl pr, pqr, rstr
| Br(kv, ll, rr) :: tl ->
let pl, pql, rstl = zipper lft ll (rr :: tl)
let pr, pqr, rstr = zipper rght pql rstl
siftdown kv.k kv.v pl pr, pqr, rstr
| Br(kv, ll, Mt) ->
let pl, pql, rstl = zipper lft ll rest
let pr, pqr, rstr = zipper rght pql rstl
siftdown kv.k kv.v pl pr, pqr, rstr
| Br(kv, ll, rr) ->
let pl, pql, rstl = zipper lft ll (rr :: rest)
let pr, pqr, rstr = zipper rght pql rstl
siftdown kv.k kv.v pl pr, pqr, rstr
let sz = size pq1 + size pq2
let pq, _, _ = zipper sz pq1 [pq2] in pq
let popMin pq = match peekMin pq with
| None -> None
| Some(kv) -> Some(kv, deleteMin pq)
let toSeq pq = Seq.unfold popMin pq
let sort sq = sq |> fromSeq |> toSeq

84
Task/Priority-queue/F-Sharp/priority-queue-3.fs Normal file
View file

@ -0,0 +1,84 @@
[<RequireQualifiedAccess>]
module PriorityQ =
type HeapEntry<'T> = struct val k:uint32 val v:'T new(k,v) = { k=k;v=v } end
type MinHeapTree<'T> = ResizeArray<HeapEntry<'T>>
let empty<'T> = MinHeapTree<HeapEntry<'T>>()
let isEmpty (pq: MinHeapTree<_>) = pq.Count = 0
let size (pq: MinHeapTree<_>) = let cnt = pq.Count
if cnt = 0 then 0 else cnt - 1
let peekMin (pq:MinHeapTree<_>) = if pq.Count > 1 then let kv = pq.[0]
Some (kv.k, kv.v) else None
let push k v (pq:MinHeapTree<_>) =
if pq.Count = 0 then pq.Add(HeapEntry(0xFFFFFFFFu,v)) //add an extra entry so there's always a right max node
let mutable nxtlvl = pq.Count in let mutable lvl = nxtlvl <<< 1 //1 past index of value added times 2
pq.Add(pq.[nxtlvl - 1]) //copy bottom entry then do bubble up while less than next level up
while ((lvl <- lvl >>> 1); nxtlvl <- nxtlvl >>> 1; nxtlvl <> 0) do
let t = pq.[nxtlvl - 1] in if t.k > k then pq.[lvl - 1] <- t else lvl <- lvl <<< 1; nxtlvl <- 0 //causes loop break
pq.[lvl - 1] <- HeapEntry(k,v); pq
let inline private siftdown k v ndx (pq: MinHeapTree<_>) =
let mutable i = ndx in let mutable ni = i in let cnt = pq.Count - 1
while (ni <- ni + ni + 1; ni < cnt) do
let lk = pq.[ni].k in let rk = pq.[ni + 1].k in let oi = i
let k = if k > lk then i <- ni; lk else k in if k > rk then ni <- ni + 1; i <- ni
if i <> oi then pq.[oi] <- pq.[i] else ni <- cnt //causes loop break
pq.[i] <- HeapEntry(k,v)
let replaceMin k v (pq:MinHeapTree<_>) = siftdown k v 0 pq; pq
let deleteMin (pq:MinHeapTree<_>) =
let lsti = pq.Count - 2
if lsti <= 0 then pq.Clear(); pq else
let lstkv = pq.[lsti]
pq.RemoveAt(lsti)
siftdown lstkv.k lstkv.v 0 pq; pq
let adjust f (pq:MinHeapTree<_>) = //adjust all the contents using the function, then re-heapify
let cnt = pq.Count - 1
let rec adj i =
let lefti = i + i + 1 in let righti = lefti + 1
let ckv = pq.[i] in let (nk, nv) = f ckv.k ckv.v
if righti < cnt then adj righti
if lefti < cnt then adj lefti; siftdown nk nv i pq
else pq.[i] <- HeapEntry(nk, nv)
adj 0; pq
let fromSeq sq =
if Seq.isEmpty sq then empty
else let pq = new MinHeapTree<_>(sq |> Seq.map (fun (k, v) -> HeapEntry(k, v)))
let sz = pq.Count in let lkv = pq.[sz - 1]
pq.Add(HeapEntry(UInt32.MaxValue, lkv.v))
let rec build i =
let lefti = i + i + 1
if lefti < sz then
let righti = lefti + 1 in build lefti; build righti
let ckv = pq.[i] in siftdown ckv.k ckv.v i pq
build 0; pq
let merge (pq1:MinHeapTree<_>) (pq2:MinHeapTree<_>) =
if pq2.Count = 0 then pq1 else
if pq1.Count = 0 then pq2 else
let pq = empty
pq.AddRange(pq1); pq.RemoveAt(pq.Count - 1)
pq.AddRange(pq2)
let sz = pq.Count - 1
let rec build i =
let lefti = i + i + 1
if lefti < sz then
let righti = lefti + 1 in build lefti; build righti
let ckv = pq.[i] in siftdown ckv.k ckv.v i pq
build 0; pq
let popMin pq = match peekMin pq with
| None -> None
| Some(kv) -> Some(kv, deleteMin pq)
let toSeq pq = Seq.unfold popMin pq
let sort sq = sq |> fromSeq |> toSeq

19
Task/Priority-queue/F-Sharp/priority-queue-4.fs Normal file
View file

@ -0,0 +1,19 @@
> let testseq = [| (3u, "Clear drains");
(4u, "Feed cat");
(5u, "Make tea");
(1u, "Solve RC tasks");
(2u, "Tax return") |] |> Array.toSeq
let testpq = testseq |> MinHeap.fromSeq
testseq |> Seq.fold (fun pq (k, v) -> MinHeap.push k v pq) MinHeap.empty
|> MinHeap.toSeq |> Seq.iter (printfn "%A") // test slow build
printfn ""
testseq |> MinHeap.fromSeq |> MinHeap.toSeq // test fast build
|> Seq.iter (printfn "%A")
printfn ""
testseq |> MinHeap.sort |> Seq.iter (printfn "%A") // convenience function
printfn ""
MinHeap.merge testpq testpq // test merge
|> MinHeap.toSeq |> Seq.iter (printfn "%A")
printfn ""
testpq |> MinHeap.adjust (fun k v -> uint32 (MinHeap.size testpq) - k, v)
|> MinHeap.toSeq |> Seq.iter (printfn "%A") // test adjust;;