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