| View in color | License | Download script | History | Other scripts by: luce80 |
30-Apr 15:46 UTC
[0.068] 37.087k
[0.068] 37.087k
 | visual-sorting.r REBOL [
title: "Visual sorting"
file: %visual-sorting.r
author: "Marco Antoniazzi"
email: [luce80 AT libero DOT it]
date: 21-03-2016
version: 0.0.10
Purpose: "Collect and show various sorting algorithms."
History: [
0.0.1 [23-02-2013 "Started"]
0.0.2 [07-03-2013 "ok"]
0.0.3 [08-03-2013 "Some aestethic fixes"]
0.0.4 [27-10-2013 "Adapted to Rebol 3 (with vid1r3.r3)" ]
0.0.5 [01-01-2014 "Little fixes and speed ups"]
0.0.6 [03-01-2014 "Inserted wait in compare function again to better see comparing"]
0.0.7 [12-01-2014 "Added pink line also to visually show swaps"]
0.0.8 [11-01-2015 "Added 25 as number of items"]
0.0.9 [12-04-2015 "Small gui changes"]
0.0.10 [21-03-2016 "Fixed bug in Heap initial division"]
]
library: [
level: 'intermediate
platform: 'all
type: [function tool]
domain: [graphics visualization]
tested-under: [View 2.7.8.3.1 Saphir-View 2.101.0.3.1]
support: none
license: 'public-domain
]
icon: http://i43.tinypic.com/2wq7srd.png
notes: {
I should say that these functions are made slow on pourpose.
The functions are written for readability and simplicity, NOT FOR SPEED.
Any optimization is left as an exercise to the reader ;)
Do not esitate to help me improve this script by adding more algorithms.
Algorithms taken from:
* http://www.xtremevbtalk.com/showthread.php?p=386994
* http://rosettacode.org/wiki/Category:Sorting_Algorithms
* http://visualsort.appspot.com/
* http://home.westman.wave.ca/~rhenry/sort/
It is particularly interesting to see the various sorting operations in
"slow motion" to better understand the similarities or the differences
between them, and also to see in which way they could be improved.
}
]
;**** set correct path to vid1r3.r3 and sdk sources (or use empty string to use default path to sdk) ****
if system/version > 2.7.8.100 [do/args %../../r3/local/vid1r3.r3 %../../sdk-2706031/rebol-sdk-276/source]
; cfor
cfor: func [
{General loop}
[throw catch]
init [block!]
test [block!]
inc [block!]
body [block!]
/local result
] [
do init while [do test] [set/any 'result do body do inc] get/any 'result
]
;
; init, reset, start, stop
widths-spaces: [
45 5
17 3
8 2
4 1
2 0
1 0
]
lengths: [10 25 50 100 250 500]
array*: make block! 10
running: false
speed: 0.1
secs: 0:0:0
reset: does [
if running [exit]
scaley: 200 / items ; bars' y scaling factor
origin: 10x30
widths: pick widths-spaces slider-value * 2 - 1
pad: origin ; origin (upper-left) of bars
gap: pick widths-spaces slider-value * 2; distance between bars
gap: gap + widths * 1x0
random/seed 18; fixed randomness
clear array*
; populate initial array
for n 1 items 1 [
insert array* switch get-face drop-type [
"Random" "Almost-Sorted" "Sorted" "Rev-Sorted" [items - n + 1]
"Many-Equals" "Equals" "Rev-Equals" [min items 4 + to-integer ((items / 5) * to-integer ((items - n) / (items / 5)))]
]
]
switch get-face drop-type [
"Almost-Sorted" [for n 1 to-integer items / 5 1 [array*/(random items): random items]]
"Random" "Many-Equals" [array*: random array*]
"Rev-Sorted" "Rev-Equals" [reverse array*]
]
comps: 0
set-face text-comps comps
swaps: 0
set-face text-swaps swaps
canvas/image/rgb: gray ; clear canvas to gray
; create an array with all the x positions of the bars
positions: copy []
for n 1 length? array* 1 [
insert tail positions pad
pad: pad + gap
]
draw-bars black
]
start: does [
time-start: now/time/precise
set-face text-time "0:00:00.000"
ticker/rate: 0:0:1 show ticker
secs: 0:0:0
text-running/font/color: blue set-face text-running "Running"
running: true
do to-word get-face drop-sorts array*
final-draws
stop
]
stop: does [
running: false
time-stop: now/time/precise - time-start
set-face text-time time-stop
ticker/rate: none show ticker
secs: 0:0:0
text-running/font/color: red set-face text-running "Stopped"
]
change-items-num: func [value [decimal!] /local temp][
if running [exit]
temp: get-face text-items
set-face text-items items: pick lengths slider-value: round value * ((length? lengths) - 1) + 1
if items != temp [reset] ; speed up things a little
]
;
; drawing
draw-triangle: func [color pos] [
draw canvas/image compose [anti-alias off pen none fill-pen (color) triangle (pos - 0x10) (pos + (widths * 1x0) - 0x10) (pos - 0x10 + (widths / 2 * 1x0) + 0x5)]
]
draw-box: func [color pos1 pos2] [
draw canvas/image compose [anti-alias off pen none fill-pen (color) box (pos1 - 2x30) (pos2 - -2x10 + (widths * 1x0))]
]
draw-arrow: func [color pos1 pos2 /local mid] [
mid: (widths / 2 * 1x0)
draw canvas/image compose [anti-alias off pen (color) fill-pen (color) line-width 2
line (pos1 - 0x15 + mid) (pos1 - 0x25 + mid) (pos2 - 0x25 + mid) (pos2 - 0x15 + mid)]
]
draw-bar: func [color pos height] [
draw canvas/image compose [anti-alias off pen none fill-pen (color) box (pos) (pos + as-pair widths height * scaley)]
]
draw-bars-erase: func [color pos1 pos2] [
draw canvas/image compose [anti-alias off pen none fill-pen (color) box (pos1) (pos2 + as-pair widths (length? array*) * scaley)]
]
draw-bars-move: func [pos1 pos2 /local image2 size off jump] [
off: 0x0
jump: gap
size: as-pair (abs pos2/x - pos1/x) 200
if pos2/x < pos1/x [pos1: pos2 off: gap jump: 0x0]
image2: copy/part at canvas/image pos1 + off size
draw canvas/image compose/deep [image (image2) (pos1 + jump)]
image2: none
]
draw-bars: func [color] [
for n 1 length? array* 1 [
draw-bar color positions/:n max 1 array*/:n
]
show canvas
]
final-draws: does [
draw-box gray positions/1 positions/(length? array*)
draw-bars white ; be sure to draw all bars in white color
set-face text-comps comps
set-face text-swaps swaps
]
;
; compare, swap, move
compare: func [array a b /local result][
if not running [throw 0] ; allow execution stopping
comps: comps + 1
result: array/:a > array/:b
either speed > 0 [
; draw triangles
draw-triangle red positions/:a
draw-triangle either a != b [red][yellow] positions/:b
show canvas
; erase triangles
draw-triangle gray positions/:a
draw-triangle gray positions/:b
set-face text-comps comps
][
show canvas
]
if not result [
draw-bar black positions/:a array/:a
draw-bar white positions/:b array/:b
]
wait speed ; listen gui events
result
]
swap: func [[catch] array a b /local temp] [
if not running [throw 0] ; allow execution stopping
temp: length? array
if any [a < 1 a > temp b < 1 b > temp][alert "Out of array limits" exit]
; erase previous line
draw-box gray positions/1 positions/(length? array)
; erase current bars
draw-bar gray positions/:a array/:a
draw-bar gray positions/:b array/:b
temp: array/:a
array/:a: array/:b
array/:b: temp
; draw a line from a to b
draw-arrow magenta positions/:b positions/:a
; draw current bars
draw-bar black positions/:a array/:a
draw-bar white positions/:b array/:b
swaps: swaps + 1
if speed > 0 [set-face text-swaps swaps]
wait speed ; listen gui events
]
move-to: func [[catch] array a b /local n] [
if not running [throw 0] ; allow execution stopping
if a = b [exit]
; erase previous line
draw-box gray positions/1 positions/(length? array)
; erase old bars
draw-bars-move positions/:b positions/:a
draw-bar gray positions/:a array/:a
draw-bar gray positions/:b array/:b
move at array a b - a
; draw a line from a to b
draw-arrow green positions/:b positions/:a
; draw current bars
draw-bar black positions/:a array/:a
draw-bar white positions/:b array/:b
show canvas ; only for Radix sorts
swaps: swaps + 1
if speed > 0 [set-face text-swaps swaps] ; to show what is happening
wait speed ; listen gui events
]
;
; sorting functions
do sorting-functions: [
Bubble-simple: func [
[throw] ; this is necessary to stop execution
array [block!]
/local item-count index-outer index
][
item-count: length? array
for index-outer 1 item-count 1 [
for index 1 item-count - index-outer 1 [
if compare array index index + 1 [
swap array index index + 1
]
]
]
]
Bubble-exit: func [
[throw] ; this is necessary to stop execution
array [block!]
/local item-count finished index
][
item-count: length? array
until [
finished: true
item-count: item-count - 1
for index 1 item-count 1 [
if compare array index index + 1 [
swap array index index + 1
finished: false
]
]
finished
]
]
Odd-Even: func [
[throw] ; this is necessary to stop execution
array [block!]
/local item-count index-outer index
][
item-count: length? array
for index-outer 1 (item-count / 2) 1 [
for index 1 item-count - 1 2 [
if compare array index index + 1 [
swap array index index + 1
]
]
for index 2 item-count - 1 2 [
if compare array index index + 1 [
swap array index index + 1
]
]
]
]
Slow: func [
[throw] ; this is necessary to stop execution
array [block!]
/local item-count index-outer index
][
item-count: length? array
for index-outer 1 item-count 1 [
for index index-outer + 1 item-count 1 [
if not compare array index index-outer [
swap array index index-outer
]
]
]
]
Cocktail: func [
[throw] ; this is necessary to stop execution
array [block!]
/local item-count lower upper finished index
][
item-count: length? array
lower: 0
upper: item-count
finished: false
while [not finished] [
lower: lower + 1
upper: upper - 1
finished: true
for index lower upper 1 [
if compare array index index + 1 [
swap array index index + 1
finished: false
]
]
if finished [break]
for index upper lower -1 [
if compare array index index + 1 [
swap array index index + 1
finished: false
]
]
]
]
Selection: func [
[throw] ; this is necessary to stop execution
array [block!]
/local item-count iMax index-outer index
][
item-count: length? array
for index-outer item-count 2 -1 [
iMax: 1
;Find the largest value in the subarray
for index 1 index-outer 1 [
if compare array index iMax [iMax: index]
]
;Swap with last slot of the subarray
swap array iMax index-outer
]
]
Selection-2: func [
[throw] ; this is necessary to stop execution
array [block!]
/local item-count imin index-outer index
][
item-count: length? array
for index-outer 1 item-count 1 [
imin: index-outer
;Find the smallest value in the subarray
for index index-outer + 1 item-count 1 [
if not compare array index imin [
imin: index
if array/(index-outer - 1) = array/(imin) [break] ; optimization
]
]
;Swap with first slot of the subarray
if imin <> index-outer [swap array imin index-outer]
]
]
Shaker: func [
[throw] ; this is necessary to stop execution
array [block!]
/local item-count lower upper imax imin index
][
item-count: length? array
lower: 1
upper: item-count
while [lower < upper] [
imin: lower
imax: lower
;find the largest and smallest values in the subarray
for index lower + 1 upper 1 [
if compare array imin index [imin: index]
if compare array index imax [imax: index]
]
;swap the smallest with the first slot of the subarray
swap array imin lower
;swap the largest with last slot of the subarray
either imax = lower [
swap array imin upper
][
swap array imax upper
]
lower: lower + 1
upper: upper - 1
]
]
Insertion: func [
[throw] ; this is necessary to stop execution
array [block!]
/local item-count index-outer index
][
item-count: length? array
for index-outer 2 item-count 1 [
;Move along the already sorted values shifting along
for index index-outer 2 -1 [
;No more shifting needed, we found the right spot!
if compare array index index - 1 [break]
swap array index - 1 index
]
]
]
Insertion-2: func [
[throw] ; this is necessary to stop execution
array [block!]
/local item-count index-outer index
][
item-count: length? array
for index-outer 2 item-count 1 [
index: 1
while [compare array index-outer index] [
index: index + 1
if index-outer = index [break]
]
move-to array index-outer index
]
]
Gnome: func [
[throw] ; this is necessary to stop execution
array [block!]
/local item-count pos prev
][
item-count: length? array
pos: 2
prev: 1
while [pos <= item-count] [
either not compare array pos - 1 pos [
if prev != 1 [
pos: prev
prev: 1
]
pos: pos + 1
][
swap array pos - 1 pos
if pos > 2 [
if prev = 1 [
prev: pos
]
pos: pos - 1
]
]
]
]
Bisecting: func [
{Insertion sort using bisection (binary search). This is my original idea. I have not found it anywhere, therefore it is:
Copyright (C) 2013-2016 Marco Antoniazzi. All rights reserved.
It is licensed under MIT licence (aknowledge is appreciated)}
[throw] ; this is necessary to stop execution
array [block!]
/local item-count index left right mid
][
item-count: length? array
for index 2 item-count 1 [
left: 1
right: index - 1
while [left <= right] [
mid: shift left + right 1
either compare array index mid [left: mid + 1][right: mid - 1]
]
move-to array index left
]
]
Comb: func [
[throw] ; this is necessary to stop execution
array [block!]
/local item-count index-outer index spacing finished
][
item-count: length? array
spacing: item-count
until [
if spacing > 1 [
spacing: to-integer spacing / 1.3
either spacing = 0 [
spacing: 1 ;dont go lower than 1
][
if all [spacing > 8 spacing < 11] [spacing: 11] ;this is a special number, goes faster than 9 and 10
]
]
;always go down to 1 before attempting to exit
if spacing = 1 [finished: true]
;combing pass
for index item-count - spacing 1 -1 [ ; go in reverse order only to be able to draw from black to white
if compare array index index + spacing [
swap array index index + spacing
;not finished
finished: false
]
]
finished
]
]
Shell: func [
[throw] ; this is necessary to stop execution
array [block!]
/local item-count spacing finished index-outer index
][
item-count: length? array
spacing: item-count
until [
; 1st part equal to comb
if spacing > 1 [
spacing: to-integer spacing * 0.76 ;/ 1.3
either spacing = 0 [
spacing: 1 ;dont go lower than 1
][
if all [spacing > 8 spacing < 11] [spacing: 11] ;this is a special number, goes faster than 9 and 10
]
]
;always go down to 1 before attempting to exit
if spacing = 1 [finished: true]
;2nd part similar to insertion
for index-outer item-count 1 + spacing -1 [ ; go in reverse order only to be able to draw from black to white
;Move along the already sorted values shifting along
for index index-outer - spacing 1 -1 [
;No more shifting needed, we found the right spot!
if not compare array index index-outer [ break]
swap array index index-outer
finished: false
]
]
finished
]
]
Heap: func [
[throw] ; this is necessary to stop execution
array [block!]
/local item-count reheap index
][
item-count: length? array
reheap: func [low high /local j son x][
j: low
forever [
if (x: j * 2) > high [break]
either (x + 1) <= high [
son: either compare array x x + 1 [x][x + 1]
][
son: x
]
either not compare array j son [
swap array j son
j: son
][
break
]
]
]
for index to-integer (item-count / 2) 1 -1 [
reheap index item-count
]
for index item-count 2 -1 [
swap array 1 index
reheap 1 index - 1
]
]
Radix-LSD: func [
[throw] ; this is necessary to stop execution
array [block!]
/local item-count num nums radix index items
][
item-count: length? array
nums: to-integer log-10 first maximum-of array
for num 0 nums 1 [
items: item-count
for digit 0 9 1 [
cfor [index: 1] [index <= items] [index: index + 1] [
radix: to-integer (array/:index / (power 10 num)) // 10
if radix = digit [
; these instructions should be substituted using blocks (10 "buckets")
move-to array index item-count
index: index - 1 ; go back to stay here
items: items - 1
]
comps: comps + 1 ; keep track of right number of compares
]
]
]
]
Radix-LSB: func [
[throw] ; this is necessary to stop execution
array [block!]
/local item-count bit mask low high finished
][
item-count: length? array
bit: 0
finished: false
until [
mask: shift/left 1 bit
low: 1
high: item-count
while [low <= high] [
either 0 != (array/:low and mask) [
move-to array low item-count
finished: true
high: high - 1
][
low: low + 1
]
comps: comps + 1 ; keep track of right number of compares
]
bit: bit + 1
all [high = item-count finished]
]
]
Radix-MSB: func [
[throw] ; this is necessary to stop execution
array [block!]
/local item-count rsort max-bits
][
item-count: length? array
rsort: func [low high bit /local left right mask][
left: low
right: high
mask: shift/left 1 bit
while [left < right] [
while [all [left < right 0 = (array/:left and mask)]] [
left: left + 1
comps: comps + 1 ; keep track of right number of compares
]
while [all [left < right 0 != (array/(right - 1) and mask)]] [
if speed > 0 [draw-bar white positions/(right - 1) array/(right - 1) show canvas wait speed] ; to show what is happening
right: right - 1
comps: comps + 1 ; keep track of right number of compares
]
if left < right [swap array left right: right - 1 left: left + 1]
show canvas
]
if all [(left > low) bit != 0] [rsort low left bit - 1]
if all [(left < high) bit != 0] [rsort left high bit - 1]
]
max-bits: 1 + to-integer log-2 first maximum-of array
rsort 1 item-count + 1 max-bits
]
Merge: func [
[throw] ; this is necessary to stop execution
array [block!]
/local item-count mergesort index
][
item-count: length? array
mergesort: func [low high /local mid][
if low = high [exit]
if (low + 1) = high [
if compare array low high [
swap array low high
]
exit
]
mid: to-integer (low + high / 2)
mergesort low mid
mergesort mid + 1 high
mid: mid + 1
while [all [low < mid mid <= high]] [
either compare array low mid [
move-to array mid low
mid: mid + 1
][
low: low + 1
]
]
]
mergesort 1 item-count
]
Quick: func [
[throw] ; this is necessary to stop execution
array [block!]
/local item-count qsort
][
item-count: length? array
qsort: func [low high /local left right pivot][
if low >= high [exit]
if (low + 1) = high [
if compare array low high [
swap array low high
]
exit
]
left: low
right: high
pivot: low
while [left < right][
while [compare array pivot left] [left: left + 1]
while [compare array right pivot] [right: right - 1]
if left <= right [
if left != right [swap array left right]
left: left + 1
right: right - 1
]
]
qsort low right
qsort left high
]
qsort 1 item-count
]
Quick-2: func [
[throw] ; this is necessary to stop execution
array [block!]
/local item-count qsort
][
item-count: length? array
qsort: func [low high /local left right p q k][
if high <= low [exit]
left: low - 1
right: high
p: low - 1
q: high
while [true] [
while [compare array high left: left + 1] []
while [compare array right: right - 1 high] [if right = low [break]]
if left >= right [break]
swap array left right
if array/:left = array/:high [swap array p: p + 1 left]
if array/:right = array/:high [swap array q: q - 1 right]
comps: comps + 2 ; keep track of right number of compares
]
swap array left high
right: left - 1
left: left + 1
for k low p - 1 1 [swap array k right right: right - 1]
for k high - 1 q + 1 -1 [swap array k left left: left + 1]
qsort low right
qsort left high
]
qsort 1 item-count
]
] ; do sorting-functions
;
; create block with sorting functions names
algorithms: copy []
forskip sorting-functions 4 [insert tail algorithms to-string first sorting-functions]
;
; gui
win: layout [
do [sp: 4x2] origin sp space sp
Across
canvas: box make image! 520x250
guide
drop-type: drop-down 130 rows 6 with [text: first list-data: ["Random" "Almost-Sorted" "Sorted" "Rev-Sorted" "Many-Equals" "Equals" "Rev-Equals"]] [reset]
return
text "Items:"
text-items: text "10" bold 30 right
return
slider-items: slider 130x20 0.0 [change-items-num to-decimal value] with [append init [redrag 0.6]]
return
drop-sorts: drop-down 130 rows 6 with [text: first list-data: algorithms]
return
text "Speed:"
text-speed: text "10" bold 30 right
return
slider 130x20 0.1 [set-face text-speed to-integer 100 * speed: round/to value / 2 0.01]
return
btn "Run" [if not running [reset catch [start]]]
btn "Stop" [if running [stop]]
;btn "Step"
btn "Reset" [reset]
return
space 4x-2
text-running: text bold red "Stopped"
return
text bold "Comparisons:"
text-comps: text 40 "0"
return
text bold "Swaps:"
text-swaps: text 40 "0"
return
text bold "Elapsed time:"
return
text-time: text "0:00:00.000"
return
ticker: sensor 0x0 rate none feel [engage: func [face action event][if event/type = 'time [set-face text-time secs: secs + 1]]]
do [
canvas/effect: [] ; remove default colorize effect and avoid image scaling
change-items-num 0.0
]
]
view/new win
do-events |