Sorting algorithms/Bead sort: Difference between revisions
m added explanation |
m →{{header|Wren}}: Minor tidy |
||
(124 intermediate revisions by 58 users not shown) | |||
Line 1: | Line 1: | ||
{{task|Sorting Algorithms |
{{task|Sorting Algorithms}} |
||
[[Category:Sorting]] |
|||
In this task, the goal is to sort an array of positive integers using the [[wp:Bead_sort|Bead Sort Algorithm]]. |
|||
{{Sorting Algorithm}} |
|||
;Task: |
|||
Algorithm has O(S), where S is the sum of the integers in the input set: Each bead is moved individually. This is the case when bead sort is implemented without a mechanism to assist in finding empty spaces below the beads, such as in software implementations. |
|||
Sort an array of positive integers using the [[wp:Bead_sort|Bead Sort Algorithm]]. |
|||
A ''bead sort'' is also known as a ''gravity sort''. |
|||
Algorithm has O(S), where S is the sum of the integers in the input set: Each bead is moved individually. |
|||
This is the case when bead sort is implemented without a mechanism to assist in finding empty spaces below the beads, such as in software implementations. |
|||
<br><br> |
|||
=={{header|11l}}== |
|||
{{trans|Nim}} |
|||
<syntaxhighlight lang="11l">F bead_sort(&a) |
|||
V maxv = max(a) |
|||
V beads = [0] * (maxv * a.len) |
|||
L(i) 0 .< a.len |
|||
L(j) 0 .< a[i] |
|||
beads[i * maxv + j] = 1 |
|||
L(j) 0 .< maxv |
|||
V sum = 0 |
|||
L(i) 0 .< a.len |
|||
sum += beads[i * maxv + j] |
|||
beads[i * maxv + j] = 0 |
|||
L(i) a.len - sum .< a.len |
|||
beads[i * maxv + j] = 1 |
|||
L(i) 0 .< a.len |
|||
V j = 0 |
|||
L j < maxv & beads[i * maxv + j] > 0 |
|||
j++ |
|||
a[i] = j |
|||
V a = [5, 3, 1, 7, 4, 1, 1, 20] |
|||
bead_sort(&a) |
|||
print(a)</syntaxhighlight> |
|||
{{out}} |
|||
<pre> |
|||
[1, 1, 1, 3, 4, 5, 7, 20] |
|||
</pre> |
|||
=={{header|360 Assembly}}== |
|||
{{trans|ooRexx}} |
|||
For maximum compatibility, this program uses only the basic instruction set (S/360) |
|||
and two ASSIST macros (XDECO,XPRNT) to keep it as short as possible. |
|||
<syntaxhighlight lang="360asm">* Bead Sort 11/05/2016 |
|||
BEADSORT CSECT |
|||
USING BEADSORT,R13 base register |
|||
SAVEAR B STM-SAVEAR(R15) skip savearea |
|||
DC 17F'0' savearea |
|||
STM STM R14,R12,12(R13) prolog |
|||
ST R13,4(R15) " |
|||
ST R15,8(R13) " |
|||
LR R13,R15 " |
|||
LA R6,1 i=1 |
|||
LOOPI1 CH R6,=AL2(N) do i=1 to hbound(z) |
|||
BH ELOOPI1 leave i |
|||
LR R1,R6 i |
|||
SLA R1,1 <<1 |
|||
LH R2,Z-2(R1) z(i) |
|||
CH R2,LO if z(i)<lo |
|||
BNL EIHO then |
|||
STH R2,LO lo=z(i) |
|||
EIHLO CH R2,HI if z(i)>hi |
|||
BNH EIHHI then |
|||
STH R2,HI hi=z(i) |
|||
EIHHI LA R6,1(R6) iterate i |
|||
B LOOPI1 next i |
|||
ELOOPI1 LA R9,1 1 |
|||
SH R9,LO -lo+1 |
|||
LA R6,1 i=1 |
|||
LOOPI2 CH R6,=AL2(N) do i=1 to hbound(z) |
|||
BH ELOOPI2 leave i |
|||
LR R1,R6 i |
|||
SLA R1,1 <<1 |
|||
LH R3,Z-2(R1) z(i) |
|||
AR R3,R9 z(i)+o |
|||
IC R2,BEADS-1(R3) beads(l) |
|||
LA R2,1(R2) beads(l)+1 |
|||
STC R2,BEADS-1(R3) beads(l)=beads(l)+1 |
|||
LA R6,1(R6) iterate i |
|||
B LOOPI2 next i |
|||
ELOOPI2 SR R8,R8 k=0 |
|||
LH R6,LO i=lo |
|||
LOOPI3 CH R6,HI do i=lo to hi |
|||
BH ELOOPI3 leave i |
|||
LA R7,1 j=1 |
|||
SR R10,R10 clear r10 |
|||
LR R1,R6 i |
|||
AR R1,R9 i+o |
|||
IC R10,BEADS-1(R1) beads(i+o) |
|||
LOOPJ3 CR R7,R10 do j=1 to beads(i+o) |
|||
BH ELOOPJ3 leave j |
|||
LA R8,1(R8) k=k+1 |
|||
LR R1,R8 k |
|||
SLA R1,1 <<1 |
|||
STH R6,S-2(R1) s(k)=i |
|||
LA R7,1(R7) iterate j |
|||
B LOOPJ3 next j |
|||
ELOOPJ3 AH R6,=H'1' iterate i |
|||
B LOOPI3 next i |
|||
ELOOPI3 LA R7,1 j=1 |
|||
LOOPJ4 CH R7,=H'2' do j=1 to 2 |
|||
BH ELOOPJ4 leave j |
|||
CH R7,=H'1' if j<>1 |
|||
BE ONE then |
|||
MVC PG(7),=C'sorted:' zap |
|||
ONE LA R10,PG+7 pgi=@pg+7 |
|||
LA R6,1 i=1 |
|||
LOOPI4 CH R6,=AL2(N) do i=1 to hbound(z) |
|||
BH ELOOPI4 leave i |
|||
CH R7,=H'1' if j=1 |
|||
BNE TWO then |
|||
LR R1,R6 i |
|||
SLA R1,1 <<1 |
|||
LH R11,Z-2(R1) zs=z(i) |
|||
B XDECO else |
|||
TWO LR R1,R6 i |
|||
SLA R1,1 <<1 |
|||
LH R11,S-2(R1) zs=s(i) |
|||
XDECO XDECO R11,XDEC edit zs |
|||
MVC 0(6,R10),XDEC+6 output zs |
|||
LA R10,6(R10) pgi=pgi+6 |
|||
LA R6,1(R6) iterate i |
|||
B LOOPI4 next i |
|||
ELOOPI4 XPRNT PG,80 print buffer |
|||
LA R7,1(R7) iterate j |
|||
B LOOPJ4 next j |
|||
ELOOPJ4 L R13,4(0,R13) epilog |
|||
LM R14,R12,12(R13) " |
|||
XR R15,R15 " |
|||
BR R14 " |
|||
LTORG literal table |
|||
N EQU (S-Z)/2 number of items |
|||
Z DC H'5',H'3',H'1',H'7',H'-1',H'4',H'9',H'-12' |
|||
DC H'2001',H'-2010',H'17',H'0' |
|||
S DS (N)H s same size as z |
|||
LO DC H'32767' 2**31-1 |
|||
HI DC H'-32768' -2**31 |
|||
PG DC CL80' raw:' buffer |
|||
XDEC DS CL12 temp |
|||
BEADS DC 4096X'00' beads |
|||
YREGS |
|||
END BEADSORT</syntaxhighlight> |
|||
{{out}} |
|||
<pre> |
|||
raw: 5 3 1 7 -1 4 9 -12 2001 -2010 17 0 |
|||
sorted: -2010 -12 -1 0 1 3 4 5 7 9 17 2001 |
|||
</pre> |
|||
=={{header|AArch64 Assembly}}== |
|||
{{works with|as|Raspberry Pi 3B version Buster 64 bits}} |
|||
<syntaxhighlight lang="aarch64 assembly"> |
|||
/* ARM assembly AARCH64 Raspberry PI 3B */ |
|||
/* program beadSort64.s */ |
|||
/* En français tri par gravité ou tri par bille (ne pas confondre |
|||
avec tri par bulle (bubble sort)) */ |
|||
/*******************************************/ |
|||
/* Constantes file */ |
|||
/*******************************************/ |
|||
/* for this file see task include a file in language AArch64 assembly*/ |
|||
.include "../includeConstantesARM64.inc" |
|||
/*********************************/ |
|||
/* Initialized data */ |
|||
/*********************************/ |
|||
.data |
|||
szMessSortOk: .asciz "Table sorted.\n" |
|||
szMessSortNok: .asciz "Table not sorted !!!!!.\n" |
|||
sMessResult: .asciz "Value : @ \n" |
|||
szCarriageReturn: .asciz "\n" |
|||
.align 4 |
|||
#TableNumber: .quad 1,3,6,2,5,9,10,8,4,7 |
|||
TableNumber: .quad 10,9,8,7,6,5,4,3,2,1 |
|||
.equ NBELEMENTS, (. - TableNumber) / 8 |
|||
//.equ NBELEMENTS, 4 // for others tests |
|||
/*********************************/ |
|||
/* UnInitialized data */ |
|||
/*********************************/ |
|||
.bss |
|||
sZoneConv: .skip 24 |
|||
/*********************************/ |
|||
/* code section */ |
|||
/*********************************/ |
|||
.text |
|||
.global main |
|||
main: // entry of program |
|||
1: |
|||
ldr x0,qAdrTableNumber // address number table |
|||
mov x1,#NBELEMENTS // number of élements |
|||
bl beadSort |
|||
ldr x0,qAdrTableNumber // address number table |
|||
mov x1,#NBELEMENTS // number of élements |
|||
bl displayTable |
|||
ldr x0,qAdrTableNumber // address number table |
|||
mov x1,#NBELEMENTS // number of élements |
|||
bl isSorted // control sort |
|||
cmp x0,#1 // sorted ? |
|||
beq 2f |
|||
ldr x0,qAdrszMessSortNok // no !! error sort |
|||
bl affichageMess |
|||
b 100f |
|||
2: // yes |
|||
ldr x0,qAdrszMessSortOk |
|||
bl affichageMess |
|||
100: // standard end of the program |
|||
mov x0, #0 // return code |
|||
mov x8, #EXIT // request to exit program |
|||
svc #0 // perform the system call |
|||
qAdrszCarriageReturn: .quad szCarriageReturn |
|||
qAdrsMessResult: .quad sMessResult |
|||
qAdrTableNumber: .quad TableNumber |
|||
qAdrszMessSortOk: .quad szMessSortOk |
|||
qAdrszMessSortNok: .quad szMessSortNok |
|||
/******************************************************************/ |
|||
/* control sorted table */ |
|||
/******************************************************************/ |
|||
/* x0 contains the address of table */ |
|||
/* x1 contains the number of elements > 0 */ |
|||
/* x0 return 0 if not sorted 1 if sorted */ |
|||
isSorted: |
|||
stp x2,lr,[sp,-16]! // save registers |
|||
stp x3,x4,[sp,-16]! // save registers |
|||
mov x2,#0 |
|||
ldr x4,[x0,x2,lsl #3] // load A[0] |
|||
1: |
|||
add x2,x2,#1 |
|||
cmp x2,x1 // end ? |
|||
bge 99f |
|||
ldr x3,[x0,x2, lsl #3] // load A[i] |
|||
cmp x3,x4 // compare A[i],A[i-1] |
|||
blt 98f // smaller -> error -> return |
|||
mov x4,x3 // no -> A[i-1] = A[i] |
|||
b 1b // and loop |
|||
98: |
|||
mov x0,#0 // error |
|||
b 100f |
|||
99: |
|||
mov x0,#1 // ok -> return |
|||
100: |
|||
ldp x2,x3,[sp],16 // restaur 2 registers |
|||
ldp x1,lr,[sp],16 // restaur 2 registers |
|||
ret // return to address lr x30 |
|||
/******************************************************************/ |
|||
/* bead sort */ |
|||
/******************************************************************/ |
|||
/* x0 contains the address of table */ |
|||
/* x1 contains the number of element */ |
|||
/* Caution registers x2-x12 are not saved */ |
|||
beadSort: |
|||
stp x1,lr,[sp,-16]! // save registers |
|||
mov x12,x1 // save elements number |
|||
//search max |
|||
ldr x10,[x0] // load value A[0] in max |
|||
mov x4,#1 |
|||
1: // loop search max |
|||
cmp x4,x12 // end ? |
|||
bge 21f // yes |
|||
ldr x2,[x0,x4,lsl #3] // load value A[i] |
|||
cmp x2,x10 // compare with max |
|||
csel x10,x2,x10,gt // if greather |
|||
add x4,x4,#1 |
|||
b 1b // loop |
|||
21: |
|||
mul x5,x10,x12 // max * elements number |
|||
lsl x5,x5,#3 // 8 bytes for each number |
|||
sub sp,sp,x5 // allocate on the stack |
|||
mov fp,sp // frame pointer = stack address |
|||
// marks beads |
|||
mov x3,x0 // save table address |
|||
mov x0,#0 // start index x |
|||
2: |
|||
mov x1,#0 // index y |
|||
ldr x8,[x3,x0,lsl #3] // load A[x] |
|||
mul x6,x0,x10 // compute bead x |
|||
3: |
|||
add x9,x6,x1 // compute bead y |
|||
mov x4,#1 // value to store |
|||
str x4,[fp,x9,lsl #3] // store to stack area |
|||
add x1,x1,#1 |
|||
cmp x1,x8 |
|||
blt 3b |
|||
31: // init to zéro the bead end |
|||
cmp x1,x10 // max ? |
|||
bge 32f |
|||
add x9,x6,x1 // compute bead y |
|||
mov x4,#0 |
|||
str x4,[fp,x9,lsl #3] |
|||
add x1,x1,#1 |
|||
b 31b |
|||
32: |
|||
add x0,x0,#1 // increment x |
|||
cmp x0,x12 // end ? |
|||
blt 2b |
|||
// count beads |
|||
mov x1,#0 // y |
|||
4: |
|||
mov x0,#0 // start index x |
|||
mov x8,#0 // sum |
|||
5: |
|||
mul x6,x0,x10 // compute bead x |
|||
add x9,x6,x1 // compute bead y |
|||
ldr x4,[fp,x9,lsl #3] |
|||
add x8,x8,x4 |
|||
mov x4,#0 |
|||
str x4,[fp,x9,lsl #3] // raz bead |
|||
add x0,x0,#1 |
|||
cmp x0,x12 |
|||
blt 5b |
|||
sub x0,x12,x8 // compute end - sum |
|||
6: |
|||
mul x6,x0,x10 // compute bead x |
|||
add x9,x6,x1 // compute bead y |
|||
mov x4,#1 |
|||
str x4,[fp,x9,lsl #3] // store new bead at end |
|||
add x0,x0,#1 |
|||
cmp x0,x12 |
|||
blt 6b |
|||
add x1,x1,#1 |
|||
cmp x1,x10 |
|||
blt 4b |
|||
// final compute |
|||
mov x0,#0 // start index x |
|||
7: |
|||
mov x1,#0 // start index y |
|||
mul x6,x0,x10 // compute bead x |
|||
8: |
|||
add x9,x6,x1 // compute bead y |
|||
ldr x4,[fp,x9,lsl #3] // load bead [x,y] |
|||
add x1,x1,#1 // add to x1 before str (index start at zéro) |
|||
cmp x4,#1 |
|||
bne 9f |
|||
str x1,[x3,x0, lsl #3] // store A[x] |
|||
9: |
|||
cmp x1,x10 // compare max |
|||
blt 8b |
|||
add x0,x0,#1 |
|||
cmp x0,x12 // end ? |
|||
blt 7b |
|||
mov x0,#0 |
|||
add sp,sp,x5 // stack alignement |
|||
100: |
|||
ldp x1,lr,[sp],16 // restaur 2 registers |
|||
ret // return to address lr x30 |
|||
/******************************************************************/ |
|||
/* Display table elements */ |
|||
/******************************************************************/ |
|||
/* x0 contains the address of table */ |
|||
/* x1 contains elements number */ |
|||
displayTable: |
|||
stp x1,lr,[sp,-16]! // save registers |
|||
stp x2,x3,[sp,-16]! // save registers |
|||
mov x2,x0 // table address |
|||
mov x4,x1 // elements number |
|||
mov x3,#0 |
|||
1: // loop display table |
|||
ldr x0,[x2,x3,lsl #3] |
|||
ldr x1,qAdrsZoneConv |
|||
bl conversion10 // décimal conversion |
|||
ldr x0,qAdrsMessResult |
|||
ldr x1,qAdrsZoneConv // insert conversion |
|||
bl strInsertAtCharInc |
|||
bl affichageMess // display message |
|||
add x3,x3,#1 |
|||
cmp x3,x4 // end ? |
|||
blt 1b // no -> loop |
|||
ldr x0,qAdrszCarriageReturn |
|||
bl affichageMess |
|||
100: |
|||
ldp x2,x3,[sp],16 // restaur 2 registers |
|||
ldp x1,lr,[sp],16 // restaur 2 registers |
|||
ret // return to address lr x30 |
|||
qAdrsZoneConv: .quad sZoneConv |
|||
/********************************************************/ |
|||
/* File Include fonctions */ |
|||
/********************************************************/ |
|||
/* for this file see task include a file in language AArch64 assembly */ |
|||
.include "../includeARM64.inc" |
|||
</syntaxhighlight> |
|||
=={{header|ARM Assembly}}== |
|||
{{works with|as|Raspberry Pi}} |
|||
<syntaxhighlight lang="arm assembly"> |
|||
/* ARM assembly Raspberry PI */ |
|||
/* program beadSort.s */ |
|||
/* En français tri par gravité ou tri par bille (ne pas confondre |
|||
avec tri par bulle (bubble sort) */ |
|||
/* REMARK 1 : this program use routines in a include file |
|||
see task Include a file language arm assembly |
|||
for the routine affichageMess conversion10 |
|||
see at end of this program the instruction include */ |
|||
/* for constantes see task include a file in arm assembly */ |
|||
/************************************/ |
|||
/* Constantes */ |
|||
/************************************/ |
|||
.include "../constantes.inc" |
|||
/*********************************/ |
|||
/* Initialized data */ |
|||
/*********************************/ |
|||
.data |
|||
szMessSortOk: .asciz "Table sorted.\n" |
|||
szMessSortNok: .asciz "Table not sorted !!!!!.\n" |
|||
sMessResult: .asciz "Value : @ \n" |
|||
szCarriageReturn: .asciz "\n" |
|||
.align 4 |
|||
TableNumber: .int 1,3,6,2,5,9,10,8,4,7 |
|||
#TableNumber: .int 10,9,8,7,6,5,4,3,2,1 |
|||
.equ NBELEMENTS, (. - TableNumber) / 4 |
|||
@.equ NBELEMENTS, 4 @ for others tests |
|||
/*********************************/ |
|||
/* UnInitialized data */ |
|||
/*********************************/ |
|||
.bss |
|||
sZoneConv: .skip 24 |
|||
/*********************************/ |
|||
/* code section */ |
|||
/*********************************/ |
|||
.text |
|||
.global main |
|||
main: @ entry of program |
|||
1: |
|||
ldr r0,iAdrTableNumber @ address number table |
|||
mov r1,#NBELEMENTS @ number of élements |
|||
bl beadSort |
|||
ldr r0,iAdrTableNumber @ address number table |
|||
mov r1,#NBELEMENTS @ number of élements |
|||
bl displayTable |
|||
ldr r0,iAdrTableNumber @ address number table |
|||
mov r1,#NBELEMENTS @ number of élements |
|||
bl isSorted @ control sort |
|||
cmp r0,#1 @ sorted ? |
|||
beq 2f |
|||
ldr r0,iAdrszMessSortNok @ no !! error sort |
|||
bl affichageMess |
|||
b 100f |
|||
2: @ yes |
|||
ldr r0,iAdrszMessSortOk |
|||
bl affichageMess |
|||
100: @ standard end of the program |
|||
mov r0, #0 @ return code |
|||
mov r7, #EXIT @ request to exit program |
|||
svc #0 @ perform the system call |
|||
iAdrszCarriageReturn: .int szCarriageReturn |
|||
iAdrsMessResult: .int sMessResult |
|||
iAdrTableNumber: .int TableNumber |
|||
iAdrszMessSortOk: .int szMessSortOk |
|||
iAdrszMessSortNok: .int szMessSortNok |
|||
/******************************************************************/ |
|||
/* control sorted table */ |
|||
/******************************************************************/ |
|||
/* r0 contains the address of table */ |
|||
/* r1 contains the number of elements > 0 */ |
|||
/* r0 return 0 if not sorted 1 if sorted */ |
|||
isSorted: |
|||
push {r2-r4,lr} @ save registers |
|||
mov r2,#0 |
|||
ldr r4,[r0,r2,lsl #2] @ load A[0] |
|||
1: |
|||
add r2,#1 |
|||
cmp r2,r1 @ end ? |
|||
movge r0,#1 @ yes -> ok -> return |
|||
bge 100f |
|||
ldr r3,[r0,r2, lsl #2] @ load A[i] |
|||
cmp r3,r4 @ compare A[i],A[i-1] |
|||
movlt r0,#0 @ smaller ? |
|||
blt 100f @ yes -> error -> return |
|||
mov r4,r3 @ no -> A[i-1] = A[i] |
|||
b 1b @ and loop |
|||
100: |
|||
pop {r2-r4,lr} |
|||
bx lr @ return |
|||
/******************************************************************/ |
|||
/* bead sort */ |
|||
/******************************************************************/ |
|||
/* r0 contains the address of table */ |
|||
/* r1 contains the number of element */ |
|||
beadSort: |
|||
push {r1-r12,lr} @ save registers |
|||
mov r12,r1 @ save elements number |
|||
@search max |
|||
ldr r10,[r0] @ load value A[0] in max |
|||
mov r4,#1 |
|||
1: @ loop search max |
|||
cmp r4,r12 @ end ? |
|||
bge 21f @ yes |
|||
ldr r2,[r0,r4,lsl #2] @ load value A[i] |
|||
cmp r2,r10 @ compare with max |
|||
movgt r10,r2 @ if greather |
|||
add r4,r4,#1 |
|||
b 1b @ loop |
|||
21: |
|||
mul r5,r10,r12 @ max * elements number |
|||
lsl r5,r5,#2 @ 4 bytes for each number |
|||
sub sp,sp,r5 @ allocate on the stack |
|||
mov fp,sp @ frame pointer = stack address |
|||
@ marks beads |
|||
mov r3,r0 @ save table address |
|||
mov r0,#0 @ start index x |
|||
2: |
|||
mov r1,#0 @ index y |
|||
ldr r7,[r3,r0,lsl #2] @ load A[x] |
|||
mul r6,r0,r10 @ compute bead x |
|||
3: |
|||
add r9,r6,r1 @ compute bead y |
|||
mov r4,#1 @ value to store |
|||
str r4,[fp,r9,lsl #2] @ store to stack area |
|||
add r1,r1,#1 |
|||
cmp r1,r7 |
|||
blt 3b |
|||
31: @ init to zéro the bead end |
|||
cmp r1,r10 @ max ? |
|||
bge 32f |
|||
add r9,r6,r1 @ compute bead y |
|||
mov r4,#0 |
|||
str r4,[fp,r9,lsl #2] |
|||
add r1,r1,#1 |
|||
b 31b |
|||
32: |
|||
add r0,r0,#1 @ increment x |
|||
cmp r0,r12 @ end ? |
|||
blt 2b |
|||
@ count beads |
|||
mov r1,#0 @ y |
|||
4: |
|||
mov r0,#0 @ start index x |
|||
mov r8,#0 @ sum |
|||
5: |
|||
mul r6,r0,r10 @ compute bead x |
|||
add r9,r6,r1 @ compute bead y |
|||
ldr r4,[fp,r9,lsl #2] |
|||
add r8,r8,r4 |
|||
mov r4,#0 |
|||
str r4,[fp,r9,lsl #2] |
|||
add r0,r0,#1 |
|||
cmp r0,r12 |
|||
blt 5b |
|||
sub r0,r12,r8 |
|||
6: |
|||
mul r6,r0,r10 @ compute bead x |
|||
add r9,r6,r1 @ compute bead y |
|||
mov r4,#1 |
|||
str r4,[fp,r9,lsl #2] |
|||
add r0,r0,#1 |
|||
cmp r0,r12 |
|||
blt 6b |
|||
add r1,r1,#1 |
|||
cmp r1,r10 |
|||
blt 4b |
|||
@ suite |
|||
mov r0,#0 @ start index |
|||
7: |
|||
mov r1,#0 |
|||
mul r6,r0,r10 @ compute bead x |
|||
8: |
|||
add r9,r6,r1 @ compute bead y |
|||
ldr r4,[fp,r9,lsl #2] |
|||
add r1,r1,#1 @ add to r1 before str (index start at zéro) |
|||
cmp r4,#1 |
|||
streq r1,[r3,r0, lsl #2] @ store A[i] |
|||
cmp r1,r10 @ compare max |
|||
blt 8b |
|||
add r0,r0,#1 |
|||
cmp r0,r12 @ end ? |
|||
blt 7b |
|||
mov r0,#0 |
|||
add sp,sp,r5 @ stack alignement |
|||
100: |
|||
pop {r1-r12,lr} |
|||
bx lr @ return |
|||
/******************************************************************/ |
|||
/* Display table elements */ |
|||
/******************************************************************/ |
|||
/* r0 contains the address of table */ |
|||
/* r1 contains elements number */ |
|||
displayTable: |
|||
push {r0-r4,lr} @ save registers |
|||
mov r2,r0 @ table address |
|||
mov r4,r1 @ elements number |
|||
mov r3,#0 |
|||
1: @ loop display table |
|||
ldr r0,[r2,r3,lsl #2] |
|||
ldr r1,iAdrsZoneConv |
|||
bl conversion10 @ décimal conversion |
|||
ldr r0,iAdrsMessResult |
|||
ldr r1,iAdrsZoneConv @ insert conversion |
|||
bl strInsertAtCharInc |
|||
bl affichageMess @ display message |
|||
add r3,r3,#1 |
|||
cmp r3,r4 @ end ? |
|||
blt 1b @ no -> loop |
|||
ldr r0,iAdrszCarriageReturn |
|||
bl affichageMess |
|||
100: |
|||
pop {r0-r4,lr} |
|||
bx lr |
|||
iAdrsZoneConv: .int sZoneConv |
|||
/***************************************************/ |
|||
/* ROUTINES INCLUDE */ |
|||
/***************************************************/ |
|||
.include "../affichage.inc" |
|||
</syntaxhighlight> |
|||
=={{header|Arturo}}== |
|||
<syntaxhighlight lang="rebol">beadSort: function [items][ |
|||
a: new items |
|||
m: neg infinity |
|||
s: 0 |
|||
loop a 'x [ |
|||
if x > m -> m: x |
|||
] |
|||
beads: array.of: m * size a 0 |
|||
loop 0..dec size a 'i [ |
|||
loop 0..dec a\[i] 'j -> |
|||
beads\[j + i * m]: 1 |
|||
] |
|||
loop 0..dec m 'j [ |
|||
s: 0 |
|||
loop 0..dec size a 'i [ |
|||
s: s + beads\[j + i*m] |
|||
beads\[j + i*m]: 0 |
|||
] |
|||
loop ((size a)-s)..dec size a 'i -> |
|||
beads\[j + i*m]: 1 |
|||
] |
|||
loop 0..dec size a 'i [ |
|||
j: 0 |
|||
while [and? [j < m] [beads\[j + i*m] > 0]] -> j: j + 1 |
|||
a\[i]: j |
|||
] |
|||
return a |
|||
] |
|||
print beadSort [3 1 2 8 5 7 9 4 6]</syntaxhighlight> |
|||
{{out}} |
|||
<pre>1 2 3 4 5 6 7 8 9</pre> |
|||
=={{header|AutoHotkey}}== |
|||
<syntaxhighlight lang="autohotkey">BeadSort(data){ |
|||
Pole:=[] , TempObj:=[], Result:=[] |
|||
for, i, v in data { |
|||
Row := i |
|||
loop, % v |
|||
MaxPole := MaxPole>A_Index?MaxPole:A_Index , Pole[A_Index, row] := 1 |
|||
} |
|||
for i , obj in Pole { |
|||
TempVar:=0 , c := A_Index |
|||
for n, v in obj |
|||
TempVar += v |
|||
loop, % TempVar |
|||
TempObj[c, A_Index] := 1 |
|||
} |
|||
loop, % Row { |
|||
TempVar:=0 , c := A_Index |
|||
Loop, % MaxPole |
|||
TempVar += TempObj[A_Index,c] |
|||
Result[c] := TempVar |
|||
} |
|||
return Result |
|||
}</syntaxhighlight> |
|||
Examples:<syntaxhighlight lang="autohotkey">for i, val in BeadSort([54,12,87,56,36]) |
|||
res := val (res?",":"") res |
|||
MsgBox % res</syntaxhighlight> |
|||
{{out}} |
|||
<pre>12,36,54,56,87</pre> |
|||
=={{header|BCPL}}== |
|||
<syntaxhighlight lang="bcpl">get "libhdr" |
|||
let max(A, len) = valof |
|||
$( let x = 0 |
|||
for i=0 to len-1 |
|||
if x<A!i do x := A!i |
|||
resultis x |
|||
$) |
|||
let beadsort(A, len) be |
|||
$( let size = max(A, len) |
|||
let tvec = getvec(size-1) |
|||
for i=0 to size-1 do tvec!i := 0 |
|||
for i=0 to len-1 |
|||
for j=0 to A!i-1 do tvec!j := tvec!j + 1 |
|||
for i=len-1 to 0 by -1 |
|||
$( let n = 0 |
|||
for j=0 to size-1 |
|||
if tvec!j > 0 |
|||
$( tvec!j := tvec!j - 1 |
|||
n := n + 1 |
|||
$) |
|||
A!i := n |
|||
$) |
|||
freevec(tvec) |
|||
$) |
|||
let write(s, A, len) be |
|||
$( writes(s) |
|||
for i=0 to len-1 do writed(A!i, 4) |
|||
wrch('*N') |
|||
$) |
|||
let start() be |
|||
$( let array = table 10,1,5,5,9,2,20,6,8,4 |
|||
let length = 10 |
|||
write("Before: ", array, length) |
|||
beadsort(array, length) |
|||
write("After: ", array, length) |
|||
$)</syntaxhighlight> |
|||
{{out}} |
|||
<pre>Before: 10 1 5 5 9 2 20 6 8 4 |
|||
After: 1 2 4 5 5 6 8 9 10 20</pre> |
|||
=={{header|C}}== |
=={{header|C}}== |
||
A rather straightforward implementation; since we do not use dynamic matrix, we have to know the maximum value in the array in advance. |
A rather straightforward implementation; since we do not use dynamic matrix, we have to know the maximum value in the array in advance. |
||
Requires (max * length) bytes for beads; if memory is of concern, bytes can be replaced by bits. |
|||
< |
<syntaxhighlight lang="c">#include <stdio.h> |
||
#include <stdlib.h> |
#include <stdlib.h> |
||
#include <stdbool.h> |
|||
#include <string.h> |
|||
void bead_sort(int *a, int len) |
|||
{ |
{ |
||
int i, j, max, sum; |
|||
unsigned char *beads; |
|||
bool fallen; |
|||
# define BEAD(i, j) beads[i * max + j] |
|||
int *t, *r = NULL; |
|||
int max = a[0]; |
|||
for (i = 1, max = a[0]; i < len; i++) |
|||
if (a[i] > max) max = a[i]; |
|||
{ |
|||
if ( a[i] < 0 ) return NULL; // we can't sort nums < 0 |
|||
if ( max < a[i] ) max = a[i]; |
|||
} |
|||
t = malloc(max*max*sizeof(int)); |
|||
if ( t == NULL ) return NULL; |
|||
memset(t, 0, max*max*sizeof(int)); |
|||
beads = calloc(1, max * len); |
|||
r = malloc(len*sizeof(int)); |
|||
memset(r, 0, len*sizeof(int)); |
|||
if (r != NULL) |
|||
{ |
|||
// "split" numbers into "beads" (units) |
|||
for(i = 0; i < len; i++) |
|||
{ |
|||
for(j = 0; j < a[i]; j++) t[i*max + j]++; |
|||
} |
|||
/* mark the beads */ |
|||
// make them fall down |
|||
for (i = 0; i < len; i++) |
|||
do |
|||
for (j = 0; j < a[i]; j++) |
|||
{ |
|||
BEAD(i, j) = 1; |
|||
fallen = false; |
|||
for(i = 0; i < max-1; i++) |
|||
{ |
for (j = 0; j < max; j++) { |
||
/* count how many beads are on each post */ |
|||
for(j = 0; j < max; j++) |
|||
for (sum = i = 0; i < len; i++) { |
|||
{ |
|||
sum += BEAD(i, j); |
|||
if ( t[i*max + j] == 1 && t[(i+1)*max + j] == 0 ) |
|||
BEAD(i, j) = 0; |
|||
{ |
|||
} |
|||
fallen = true; |
|||
/* mark bottom sum beads */ |
|||
t[i*max + j] = 0; |
|||
for (i = len - sum; i < len; i++) BEAD(i, j) = 1; |
|||
} |
|||
} |
} |
||
} |
|||
} while(fallen); |
|||
for (i = 0; i < len; i++) { |
|||
#if defined(SHOW_BEADS) |
|||
for (j = 0; j < max && BEAD(i, j); j++); |
|||
a[i] = j; |
|||
{ |
|||
} |
|||
for(j = 0; j < max; j++) |
|||
free(beads); |
|||
{ |
|||
printf("%d ", t[i*max + j]); |
|||
} |
|||
printf("\n"); |
|||
} |
|||
#endif |
|||
// count beads |
|||
k = 0; |
|||
for(i = 0; i < max; i++) |
|||
{ |
|||
if ( t[(max - i - 1)*max + 0] == 0 ) break; |
|||
for(j = 0; j < max; j++) |
|||
{ |
|||
int v = t[(max - i - 1)*max + j]; |
|||
if ( v == 0 ) break; |
|||
r[k] += v; |
|||
} |
|||
k++; |
|||
} |
|||
} |
|||
free(t); |
|||
return r; |
|||
} |
} |
||
int main() |
int main() |
||
{ |
{ |
||
int i, x[] = {5, 3, 1, 7, 4, 1, 1, 20}; |
|||
int len = sizeof(x)/sizeof(x[0]); |
|||
int *r = bead_sort(values, len); |
|||
if ( r == NULL ) return EXIT_FAILURE; |
|||
bead_sort(x, len); |
|||
for(i = 0; i < len; i++) |
|||
for (i = 0; i < len; i++) |
|||
{ |
|||
printf("%d\n", x[i]); |
|||
} |
|||
putchar('\n'); |
|||
return 0; |
|||
free(r); |
|||
}</syntaxhighlight> |
|||
return EXIT_SUCCESS; |
|||
}</lang> |
|||
=={{header|C++}}== |
=={{header|C++}}== |
||
< |
<syntaxhighlight lang="cpp">//this algorithm only works with positive, whole numbers. |
||
//O(2n) time complexity where n is the summation of the whole list to be sorted. |
//O(2n) time complexity where n is the summation of the whole list to be sorted. |
||
//O(3n) space complexity. |
//O(3n) space complexity. |
||
Line 151: | Line 847: | ||
int myints[] = {734,3,1,24,324,324,32,432,42,3,4,1,1}; |
int myints[] = {734,3,1,24,324,324,32,432,42,3,4,1,1}; |
||
vector<int> sorted = beadSort(myints, sizeof(myints)/sizeof(int)); |
vector<int> sorted = beadSort(myints, sizeof(myints)/sizeof(int)); |
||
cout << "Sorted list/array" |
cout << "Sorted list/array: "; |
||
for(unsigned int i=0; i<sorted.size(); i++) |
for(unsigned int i=0; i<sorted.size(); i++) |
||
cout << sorted[i] << ' '; |
cout << sorted[i] << ' '; |
||
}</ |
}</syntaxhighlight> |
||
=={{header|Clojure}}== |
=={{header|Clojure}}== |
||
{{trans|Haskell}} |
{{trans|Haskell}} |
||
< |
<syntaxhighlight lang="clojure">(defn transpose [xs] |
||
(loop [ |
(loop [ret [], remain xs] |
||
(if (empty? |
(if (empty? remain) |
||
ret |
|||
(recur |
(recur (conj ret (map first remain)) |
||
( |
(filter not-empty (map rest remain)))))) |
||
(filter #(not-empty %) (map #(rest %) remaining)))) )) |
|||
(defn bead-sort [xs] |
(defn bead-sort [xs] |
||
(->> xs |
|||
(map #(reduce + %) |
|||
( |
(map #(repeat % 1)) |
||
transpose |
|||
transpose |
|||
(map #(reduce + %)))) |
|||
;; This algorithm does not work if collection has zero |
|||
(-> [5 2 4 1 3 3 9] bead-sort println) |
|||
</syntaxhighlight> |
|||
{{out}} |
|||
(println (bead-sort [5 2 4 1 3 3 9])) |
|||
<pre>(9 5 4 3 3 2 1)</pre> |
|||
</lang> |
|||
=={{header|COBOL}}== |
|||
{{works with|GnuCOBOL}} |
|||
<syntaxhighlight lang="cobol"> >>SOURCE FORMAT FREE |
|||
*> This code is dedicated to the public domain |
|||
*> This is GNUCOBOL 2.0 |
|||
identification division. |
|||
program-id. beadsort. |
|||
environment division. |
|||
configuration section. |
|||
repository. function all intrinsic. |
|||
data division. |
|||
working-storage section. |
|||
01 filler. |
|||
03 row occurs 9 pic x(9). |
|||
03 r pic 99. |
|||
03 r1 pic 99. |
|||
03 r2 pic 99. |
|||
03 pole pic 99. |
|||
03 a-lim pic 99 value 9. |
|||
03 a pic 99. |
|||
03 array occurs 9 pic 9. |
|||
01 NL pic x value x'0A'. |
|||
procedure division. |
|||
start-beadsort. |
|||
*> fill the array |
|||
compute a = random(seconds-past-midnight) |
|||
perform varying a from 1 by 1 until a > a-lim |
|||
compute array(a) = random() * 10 |
|||
end-perform |
|||
perform display-array |
|||
display space 'initial array' |
|||
*> distribute the beads |
|||
perform varying r from 1 by 1 until r > a-lim |
|||
move all '.' to row(r) |
|||
perform varying pole from 1 by 1 until pole > array(r) |
|||
move 'o' to row(r)(pole:1) |
|||
end-perform |
|||
end-perform |
|||
display NL 'initial beads' |
|||
perform display-beads |
|||
*> drop the beads |
|||
perform varying pole from 1 by 1 until pole > a-lim |
|||
move a-lim to r2 |
|||
perform find-opening |
|||
compute r1 = r2 - 1 |
|||
perform find-bead |
|||
perform until r1 = 0 *> no bead or no opening |
|||
*> drop the bead |
|||
move '.' to row(r1)(pole:1) |
|||
move 'o' to row(r2)(pole:1) |
|||
*> continue up the pole |
|||
compute r2 = r2 - 1 |
|||
perform find-opening |
|||
compute r1 = r2 - 1 |
|||
perform find-bead |
|||
end-perform |
|||
end-perform |
|||
display NL 'dropped beads' |
|||
perform display-beads |
|||
*> count the beads in each row |
|||
perform varying r from 1 by 1 until r > a-lim |
|||
move 0 to array(r) |
|||
inspect row(r) tallying array(r) |
|||
for all 'o' before initial '.' |
|||
end-perform |
|||
perform display-array |
|||
display space 'sorted array' |
|||
stop run |
|||
. |
|||
find-opening. |
|||
perform varying r2 from r2 by -1 |
|||
until r2 = 1 or row(r2)(pole:1) = '.' |
|||
continue |
|||
end-perform |
|||
. |
|||
find-bead. |
|||
perform varying r1 from r1 by -1 |
|||
until r1 = 0 or row(r1)(pole:1) = 'o' |
|||
continue |
|||
end-perform |
|||
. |
|||
display-array. |
|||
display space |
|||
perform varying a from 1 by 1 until a > a-lim |
|||
display space array(a) with no advancing |
|||
end-perform |
|||
. |
|||
display-beads. |
|||
perform varying r from 1 by 1 until r > a-lim |
|||
display row(r) |
|||
end-perform |
|||
. |
|||
end program beadsort.</syntaxhighlight> |
|||
{{out}} |
|||
<pre>prompt$ cobc -xj beadsort.cob |
|||
3 2 1 6 1 6 4 9 7 initial array |
|||
initial beads |
|||
ooo...... |
|||
oo....... |
|||
o........ |
|||
oooooo... |
|||
o........ |
|||
oooooo... |
|||
oooo..... |
|||
ooooooooo |
|||
ooooooo.. |
|||
dropped beads |
|||
o........ |
|||
o........ |
|||
oo....... |
|||
ooo...... |
|||
oooo..... |
|||
oooooo... |
|||
oooooo... |
|||
ooooooo.. |
|||
ooooooooo |
|||
1 1 2 3 4 6 6 7 9 sorted array</pre> |
|||
=={{header|Common Lisp}}== |
|||
{{trans|Clojure}} |
|||
<syntaxhighlight lang="lisp"> |
|||
(defun transpose (remain &optional (ret '())) |
|||
(if (null remain) |
|||
ret |
|||
(transpose (remove-if #'null (mapcar #'cdr remain)) |
|||
(append ret (list (mapcar #'car remain)))))) |
|||
(defun bead-sort (xs) |
|||
(mapcar #'length (transpose (transpose (mapcar (lambda (x) (make-list x :initial-element 1)) xs))))) |
|||
(bead-sort '(5 2 4 1 3 3 9)) |
|||
Output: |
|||
</syntaxhighlight> |
|||
{{out}} |
|||
<pre>(9 5 4 3 3 2 1)</pre> |
<pre>(9 5 4 3 3 2 1)</pre> |
||
=={{header|D}}== |
=={{header|D}}== |
||
A functional-style solution. |
|||
{{trans|Python}} |
|||
< |
<syntaxhighlight lang="d">import std.stdio, std.algorithm, std.range, std.array, std.functional; |
||
alias repeat0 = curry!(repeat, 0); |
|||
auto beadSort(int[] l) { |
|||
auto columns(R)(R m) { |
|||
// Currenty std.range.transposed doesn't work. |
|||
int[][] r; |
|||
auto columns(R)(R m) pure /*nothrow*/ @safe /*@nogc*/ { |
|||
foreach (i; 0 .. reduce!max(map!walkLength(m))) { |
|||
return m |
|||
r.length += 1; |
|||
.map!walkLength |
|||
.reduce!max |
|||
.iota |
|||
.map!(i => m.filter!(s => s.length > i).walkLength.repeat0); |
|||
} |
|||
} |
|||
return r; |
|||
} |
|||
auto beadSort(in uint[] data) pure /*nothrow @nogc*/ { |
|||
auto m = map!"new int[a]"(l); |
|||
return map! |
return data.map!repeat0.columns.columns.map!walkLength; |
||
} |
} |
||
void main() { |
void main() { |
||
[5, 3, 1, 7, 4, 1, 1].beadSort.writeln; |
|||
}</ |
}</syntaxhighlight> |
||
{{out}} |
|||
Output (D V.2.048): |
|||
<pre>[7, 5, 4, 3, 1, 1, 1]</pre> |
<pre>[7, 5, 4, 3, 1, 1, 1]</pre> |
||
=={{header|Delphi}}== |
|||
{{trans|C}} |
|||
<syntaxhighlight lang="d">program BeadSortTest; |
|||
{$APPTYPE CONSOLE} |
|||
uses |
|||
SysUtils; |
|||
procedure BeadSort(var a : array of integer); |
|||
var |
|||
i, j, max, sum : integer; |
|||
beads : array of array of integer; |
|||
begin |
|||
max := a[Low(a)]; |
|||
for i := Low(a) + 1 to High(a) do |
|||
if a[i] > max then |
|||
max := a[i]; |
|||
SetLength(beads, High(a) - Low(a) + 1, max); |
|||
// mark the beads |
|||
for i := Low(a) to High(a) do |
|||
for j := 0 to a[i] - 1 do |
|||
beads[i, j] := 1; |
|||
for j := 0 to max - 1 do |
|||
begin |
|||
// count how many beads are on each post |
|||
sum := 0; |
|||
for i := Low(a) to High(a) do |
|||
begin |
|||
sum := sum + beads[i, j]; |
|||
beads[i, j] := 0; |
|||
end; |
|||
//mark bottom sum beads |
|||
for i := High(a) + 1 - sum to High(a) do |
|||
beads[i, j] := 1; |
|||
end; |
|||
for i := Low(a) to High(a) do |
|||
begin |
|||
j := 0; |
|||
while (j < max) and (beads[i, j] <> 0) do |
|||
inc(j); |
|||
a[i] := j; |
|||
end; |
|||
SetLength(beads, 0, 0); |
|||
end; |
|||
const |
|||
N = 8; |
|||
var |
|||
i : integer; |
|||
x : array[1..N] of integer = (5, 3, 1, 7, 4, 1, 1, 20); |
|||
begin |
|||
for i := 1 to N do |
|||
writeln(Format('x[%d] = %d', [i, x[i]])); |
|||
BeadSort(x); |
|||
for i := 1 to N do |
|||
writeln(Format('x[%d] = %d', [i, x[i]])); |
|||
readln; |
|||
end.</syntaxhighlight> |
|||
--[[User:Davidizadar|DavidIzadaR]] 18:12, 7 August 2011 (UTC) |
|||
=={{header|Eiffel}}== |
|||
<syntaxhighlight lang="eiffel"> |
|||
class |
|||
BEAD_SORT |
|||
feature |
|||
bead_sort (ar: ARRAY [INTEGER]): ARRAY [INTEGER] |
|||
-- Sorted array in descending order. |
|||
require |
|||
only_positive_integers: across ar as a all a.item > 0 end |
|||
local |
|||
max, count, i, j, k: INTEGER |
|||
do |
|||
max := max_item (ar) |
|||
create Result.make_filled (0, 1, ar.count) |
|||
from |
|||
i := 1 |
|||
until |
|||
i > max |
|||
loop |
|||
count := 0 |
|||
from |
|||
k := 1 |
|||
until |
|||
k > ar.count |
|||
loop |
|||
if ar.item (k) >= i then |
|||
count := count + 1 |
|||
end |
|||
k := k + 1 |
|||
end |
|||
from |
|||
j := 1 |
|||
until |
|||
j > count |
|||
loop |
|||
Result [j] := i |
|||
j := j + 1 |
|||
end |
|||
i := i + 1 |
|||
end |
|||
ensure |
|||
array_is_sorted: is_sorted (Result) |
|||
end |
|||
feature {NONE} |
|||
max_item (ar: ARRAY [INTEGER]): INTEGER |
|||
-- Max item of 'ar'. |
|||
require |
|||
ar_not_void: ar /= Void |
|||
do |
|||
across |
|||
ar as a |
|||
loop |
|||
if a.item > Result then |
|||
Result := a.item |
|||
end |
|||
end |
|||
ensure |
|||
Result_is_max: across ar as a all a.item <= Result end |
|||
end |
|||
is_sorted (ar: ARRAY [INTEGER]): BOOLEAN |
|||
--- Is 'ar' sorted in descending order? |
|||
require |
|||
ar_not_empty: ar.is_empty = False |
|||
local |
|||
i: INTEGER |
|||
do |
|||
Result := True |
|||
from |
|||
i := ar.lower |
|||
until |
|||
i = ar.upper |
|||
loop |
|||
if ar [i] < ar [i + 1] then |
|||
Result := False |
|||
end |
|||
i := i + 1 |
|||
end |
|||
end |
|||
end |
|||
</syntaxhighlight> |
|||
Test: |
|||
<syntaxhighlight lang="eiffel"> |
|||
class |
|||
APPLICATION |
|||
create |
|||
make |
|||
feature |
|||
make |
|||
do |
|||
test := <<1, 5, 99, 2, 95, 7, 7>> |
|||
create beadsort |
|||
io.put_string ("unsorted:" + "%N") |
|||
across |
|||
test as ar |
|||
loop |
|||
io.put_string (ar.item.out + "%T") |
|||
end |
|||
io.put_string ("%N" + "sorted:" + "%N") |
|||
test := beadsort.bead_sort (test) |
|||
across |
|||
test as ar |
|||
loop |
|||
io.put_string (ar.item.out + "%T") |
|||
end |
|||
end |
|||
beadsort: BEAD_SORT |
|||
test: ARRAY [INTEGER] |
|||
end |
|||
</syntaxhighlight> |
|||
{{out}} |
|||
<pre> |
|||
unsorted: |
|||
1 5 99 2 95 7 7 |
|||
sorted: |
|||
99 95 7 7 5 2 1 |
|||
</pre> |
|||
=={{header|Elixir}}== |
|||
{{trans|Erlang}} |
|||
<syntaxhighlight lang="elixir">defmodule Sort do |
|||
def bead_sort(list) when is_list(list), do: dist(dist(list)) |
|||
defp dist(list), do: List.foldl(list, [], fn(n, acc) when n>0 -> dist(acc, n, []) end) |
|||
defp dist([], 0, acc), do: Enum.reverse(acc) |
|||
defp dist([h|t], 0, acc), do: dist(t, 0, [h |acc]) |
|||
defp dist([], n, acc), do: dist([], n-1, [1 |acc]) |
|||
defp dist([h|t], n, acc), do: dist(t, n-1, [h+1|acc]) |
|||
end</syntaxhighlight> |
|||
Example: |
|||
<pre> |
|||
iex(20)> Sort.bead_sort([5,3,9,4,1,6,8,2,7]) |
|||
[9, 8, 7, 6, 5, 4, 3, 2, 1] |
|||
</pre> |
|||
=={{header|Erlang}}== |
|||
<syntaxhighlight lang="erlang">-module(beadsort). |
|||
-export([sort/1]). |
|||
sort(L) -> |
|||
dist(dist(L)). |
|||
dist(L) when is_list(L) -> |
|||
lists:foldl(fun (N, Acc) -> dist(Acc, N, []) end, [], L). |
|||
dist([H | T], N, Acc) when N > 0 -> |
|||
dist(T, N - 1, [H + 1 | Acc]); |
|||
dist([], N, Acc) when N > 0 -> |
|||
dist([], N - 1, [1 | Acc]); |
|||
dist([H | T], 0, Acc) -> |
|||
dist(T, 0, [H | Acc]); |
|||
dist([], 0, Acc) -> |
|||
lists:reverse(Acc).</syntaxhighlight> |
|||
Example; |
|||
<syntaxhighlight lang="erlang">1> beadsort:sort([1,734,24,3,324,324,32,432,42,3,4,1,1]). |
|||
[734,432,324,324,42,32,24,4,3,3,1,1,1]</syntaxhighlight> |
|||
=={{header|F_Sharp|F#}}== |
=={{header|F_Sharp|F#}}== |
||
{{trans|Haskell}} |
{{trans|Haskell}} |
||
< |
<syntaxhighlight lang="fsharp">open System |
||
let removeEmptyLists lists = lists |> List.filter (not << List.isEmpty) |
let removeEmptyLists lists = lists |> List.filter (not << List.isEmpty) |
||
Line 219: | Line 1,305: | ||
// Using the forward composition operator ">>" ... |
// Using the forward composition operator ">>" ... |
||
let beadSort2 = List.map (flip List.replicate 1) >> transpose >> transpose >> List.map List.sum</ |
let beadSort2 = List.map (flip List.replicate 1) >> transpose >> transpose >> List.map List.sum</syntaxhighlight> |
||
Usage: beadSort [2;4;1;3;3] or beadSort2 [2;4;1;3;3] |
Usage: beadSort [2;4;1;3;3] or beadSort2 [2;4;1;3;3] |
||
{{out}} |
|||
Output: |
|||
<pre> |
<pre> |
||
val it : int list = [4; 3; 3; 2; 1] |
val it : int list = [4; 3; 3; 2; 1] |
||
</pre> |
</pre> |
||
=={{header|Factor}}== |
|||
<syntaxhighlight lang="factor">USING: kernel math math.order math.vectors sequences ; |
|||
: fill ( seq len -- newseq ) [ dup length ] dip swap - 0 <repetition> append ; |
|||
: bead ( seq -- newseq ) |
|||
dup 0 [ max ] reduce |
|||
[ swap 1 <repetition> swap fill ] curry map |
|||
[ ] [ v+ ] map-reduce ; |
|||
: beadsort ( seq -- newseq ) bead bead ;</syntaxhighlight> |
|||
<syntaxhighlight lang="factor">( scratchpad ) { 5 2 4 1 3 3 9 } beadsort . |
|||
{ 9 5 4 3 3 2 1 }</syntaxhighlight> |
|||
=={{header|Fortran}}== |
=={{header|Fortran}}== |
||
Line 238: | Line 1,337: | ||
very same code would run fine even with large integers. |
very same code would run fine even with large integers. |
||
< |
<syntaxhighlight lang="fortran">program BeadSortTest |
||
use iso_fortran_env |
use iso_fortran_env |
||
! for ERROR_UNIT; to make this a F95 code, |
! for ERROR_UNIT; to make this a F95 code, |
||
Line 278: | Line 1,377: | ||
end subroutine beadsort |
end subroutine beadsort |
||
end program BeadSortTest</ |
end program BeadSortTest</syntaxhighlight> |
||
=={{header|FreeBASIC}}== |
|||
<syntaxhighlight lang="freebasic">#define MAXNUM 100 |
|||
Sub beadSort(bs() As Long) |
|||
Dim As Long i, j = 1, lb = Lbound(bs), ub = Ubound(bs) |
|||
Dim As Long poles(MAXNUM) |
|||
For i = 1 To ub |
|||
For j = 1 To bs(i) |
|||
poles(j) += 1 |
|||
Next j |
|||
Next i |
|||
For j = 1 To ub |
|||
bs(j) = 0 |
|||
Next j |
|||
For i = 1 To Ubound(poles) |
|||
For j = 1 To poles(i) |
|||
bs(j) += 1 |
|||
Next j |
|||
Next i |
|||
End Sub |
|||
'--- Programa Principal --- |
|||
Dim As Long i |
|||
Dim As Ulong array(1 To 8) => {5, 3, 1, 7, 4, 1, 1, 20} |
|||
Dim As Long a = Lbound(array), b = Ubound(array) |
|||
Randomize Timer |
|||
Print "unsort "; |
|||
For i = a To b : Print Using "####"; array(i); : Next i |
|||
beadSort(array()) |
|||
Print !"\n sort "; |
|||
For i = a To b : Print Using "####"; array(i); : Next i |
|||
Print !"\n--- terminado, pulsa RETURN---" |
|||
Sleep</syntaxhighlight> |
|||
{{out}} |
|||
<pre>unsort 5 3 1 7 4 1 1 20 |
|||
sort 20 7 5 4 3 1 1 1</pre> |
|||
=={{header|Go}}== |
=={{header|Go}}== |
||
Sorts non-negative integers only. The extension to negative values seemed a distraction from this fun task. |
Sorts non-negative integers only. The extension to negative values seemed a distraction from this fun task. |
||
< |
<syntaxhighlight lang="go">package main |
||
import ( |
import ( |
||
Line 290: | Line 1,434: | ||
var a = []int{170, 45, 75, 90, 802, 24, 2, 66} |
var a = []int{170, 45, 75, 90, 802, 24, 2, 66} |
||
var aMax = 1000 |
var aMax = 1000 |
||
const bead = 'o' |
|||
func main() { |
func main() { |
||
Line 298: | Line 1,444: | ||
func beadSort() { |
func beadSort() { |
||
// |
// All space in the abacus = aMax poles x len(a) rows. |
||
all := make([]byte, aMax*len(a)) |
|||
// Slice up space by pole. (The space could be sliced by row instead, |
|||
for iPole := range abacus { |
|||
// but slicing by pole seemed a more intuitive model of a physical abacus.) |
|||
abacus[iPole] = make(chan byte, len(a)) |
|||
abacus := make([][]byte, aMax) |
|||
for pole, space := 0, all; pole < aMax; pole++ { |
|||
abacus[pole] = space[:len(a)] |
|||
space = space[len(a):] |
|||
} |
} |
||
// Use a sync.Waitgroup as the checkpoint mechanism. |
|||
const bead = 'o' |
|||
var wg sync.WaitGroup |
|||
// Values to be sorted are modeled as concurrent |
|||
// |
// Place beads for each number concurrently. (Presumably beads can be |
||
// "snapped on" to the middle of a pole without disturbing neighboring |
|||
// Sending a bead on a channel corresponds to |
|||
// beads.) Also note 'row' here is a row of the abacus. |
|||
// letting it fall. The WaitGroup falling tracks |
|||
wg.Add(len(a)) |
|||
// the number of rows of beads that are falling. |
|||
for row, n := range a { |
|||
var falling sync.WaitGroup |
|||
go func(row, n int) { |
|||
for pole := 0; pole < n; pole++ { |
|||
abacus[pole][row] = bead |
|||
for iPole := 0; iPole < x; iPole++ { |
|||
abacus[iPole] <- bead |
|||
} |
} |
||
wg.Done() |
|||
}( |
}(row, n) |
||
} |
} |
||
wg.Wait() |
|||
// Beads fall concurrently as CPU cores are available. |
|||
// Now tip the abacus, letting beads fall on each pole concurrently. |
|||
// When all beads are done falling, the numbers can |
|||
wg.Add(aMax) |
|||
// read out from highest to lowest. |
|||
for _, pole := range abacus { |
|||
falling.Wait() |
|||
go func(pole []byte) { |
|||
// Track the top of the stack of beads that have already fallen. |
|||
x := 0 |
|||
top := 0 |
|||
for row, space := range pole { |
|||
if space == bead { |
|||
// Move each bead individually, but move it from its |
|||
// starting row to the top of stack in a single operation. |
|||
// (More physical simulation such as discovering the top |
|||
default: |
|||
// of stack by inspection, or modeling gravity, are |
|||
// possible, but didn't seem called for by the task. |
|||
pole[row] = 0 |
|||
pole[top] = bead |
|||
top++ |
|||
} |
|||
} |
} |
||
wg.Done() |
|||
}(pole) |
|||
} |
|||
wg.Wait() |
|||
// Read out sorted numbers by row. |
|||
for row := range a { |
|||
x := 0 |
|||
for pole := 0; pole < aMax && abacus[pole][row] == bead; pole++ { |
|||
x++ |
|||
} |
} |
||
a[ |
a[len(a)-1-row] = x |
||
} |
} |
||
}</ |
}</syntaxhighlight> |
||
=={{header|Groovy}}== |
=={{header|Groovy}}== |
||
Solution: |
Solution: |
||
< |
<syntaxhighlight lang="groovy">def beadSort = { list -> |
||
final nPoles = list.max() |
final nPoles = list.max() |
||
list.collect { |
list.collect { |
||
Line 351: | Line 1,513: | ||
beadTally.findAll{ it }.size() |
beadTally.findAll{ it }.size() |
||
} |
} |
||
}</ |
}</syntaxhighlight> |
||
Annotated Solution (same solution really): |
Annotated Solution (same solution really): |
||
< |
<syntaxhighlight lang="groovy">def beadSortVerbose = { list -> |
||
final nPoles = list.max() |
final nPoles = list.max() |
||
// each row is a number tally-arrayed across the abacus |
// each row is a number tally-arrayed across the abacus |
||
Line 372: | Line 1,534: | ||
def beadTalliesDrop = abacusPolesDrop.transpose() |
def beadTalliesDrop = abacusPolesDrop.transpose() |
||
beadTalliesDrop.collect{ beadTally -> beadTally.findAll{ it }.size() } |
beadTalliesDrop.collect{ beadTally -> beadTally.findAll{ it }.size() } |
||
}</ |
}</syntaxhighlight> |
||
Test: |
Test: |
||
< |
<syntaxhighlight lang="groovy">println beadSort([23,76,99,58,97,57,35,89,51,38,95,92,24,46,31,24,14,12,57,78,4]) |
||
println beadSort([88,18,31,44,4,0,8,81,14,78,20,76,84,33,73,75,82,5,62,70,12,7,1])</ |
println beadSort([88,18,31,44,4,0,8,81,14,78,20,76,84,33,73,75,82,5,62,70,12,7,1])</syntaxhighlight> |
||
{{out}} |
|||
Output: |
|||
<pre>........................................................................................................................[4, 12, 14, 23, 24, 24, 31, 35, 38, 46, 51, 57, 57, 58, 76, 78, 89, 92, 95, 97, 99] |
<pre>........................................................................................................................[4, 12, 14, 23, 24, 24, 31, 35, 38, 46, 51, 57, 57, 58, 76, 78, 89, 92, 95, 97, 99] |
||
...............................................................................................................[0, 1, 4, 5, 7, 8, 12, 14, 18, 20, 31, 33, 44, 62, 70, 73, 75, 76, 78, 81, 82, 84, 88]</pre> |
...............................................................................................................[0, 1, 4, 5, 7, 8, 12, 14, 18, 20, 31, 33, 44, 62, 70, 73, 75, 76, 78, 81, 82, 84, 88]</pre> |
||
Line 387: | Line 1,549: | ||
=={{header|Haskell}}== |
=={{header|Haskell}}== |
||
< |
<syntaxhighlight lang="haskell">import Data.List |
||
beadSort :: [Int] -> [Int] |
beadSort :: [Int] -> [Int] |
||
beadSort = map sum. transpose. transpose. map (flip replicate 1)</ |
beadSort = map sum. transpose. transpose. map (flip replicate 1)</syntaxhighlight> |
||
Example; |
Example; |
||
< |
<syntaxhighlight lang="haskell">*Main> beadSort [2,4,1,3,3] |
||
[4,3,3,2,1]</ |
[4,3,3,2,1]</syntaxhighlight> |
||
=={{header|Icon}} and {{header|Unicon}}== |
=={{header|Icon}} and {{header|Unicon}}== |
||
The program below handles integers and not just whole numbers. As are so many others, the solution is limited by the lack of sparse array or list compression. |
The program below handles integers and not just whole numbers. As are so many others, the solution is limited by the lack of sparse array or list compression. |
||
{{lines too long}} |
|||
<lang |
<syntaxhighlight lang="icon">procedure main() #: demonstrate various ways to sort a list and string |
||
write("Sorting Demo using ",image(beadsort)) |
write("Sorting Demo using ",image(beadsort)) |
||
writes(" on list : ") |
writes(" on list : ") |
||
Line 405: | Line 1,567: | ||
end |
end |
||
procedure beadsort(X) |
procedure beadsort(X) #: return sorted list ascending(or descending) |
||
local base,i,j,x |
local base,i,j,x # handles negatives and zeros, may also reduce storage |
||
poles := list(max!X-(base := min!X -1),0) |
poles := list(max!X-(base := min!X -1),0) # set up poles, we will track sums not individual beads |
||
every x := !X do { |
every x := !X do { # each item in the list |
||
if integer(x) ~= x then runerr(101,x) |
if integer(x) ~= x then runerr(101,x) # ... must be an integer |
||
every poles[1 to x - base] +:= 1 |
every poles[1 to x - base] +:= 1 # ... beads "fall" into the sum for that pole |
||
} |
} |
||
every (X[j := *X to 1 by -1] := base) & |
every (X[j := *X to 1 by -1] := base) & |
||
(i := 1 to *poles) do # read from the bottom of the poles |
|||
if poles[i] > 0 then { # if there's a bead on the pole ... |
|||
poles[i] -:= 1 # ... remove it |
|||
X[j] +:= 1 # ... and add it in place |
|||
} |
} |
||
return X |
return X |
||
end</ |
end</syntaxhighlight> |
||
Note: This example relies on [[Sorting_algorithms/Bubble_sort#Icon| the supporting procedures 'writex' in Bubble Sort]]. |
Note: This example relies on [[Sorting_algorithms/Bubble_sort#Icon| the supporting procedures 'writex' in Bubble Sort]]. |
||
Note: min and max are available in the Icon Programming Library (IPL). |
|||
{{out|Abbreviated sample output}} |
|||
{{improve|Unicon|Need to confirm if min/max are native in Icon. They are available in the IPL}} |
|||
<pre>Sorting Demo using procedure beadsort |
|||
Abbreviated sample output:<pre>Sorting Demo using procedure beadsort |
|||
on list : [ 3 14 1 5 9 2 6 3 ] |
on list : [ 3 14 1 5 9 2 6 3 ] |
||
with op = &null: [ 1 2 3 3 5 6 9 14 ] (0 ms)</pre> |
with op = &null: [ 1 2 3 3 5 6 9 14 ] (0 ms)</pre> |
||
Line 435: | Line 1,598: | ||
{{eff note|J|\:~}} |
{{eff note|J|\:~}} |
||
< |
<syntaxhighlight lang="j">bead=: [: +/ #"0&1</syntaxhighlight> |
||
Example use: |
Example use: |
||
<lang> bead bead 2 4 1 3 3 |
<syntaxhighlight lang="text"> bead bead 2 4 1 3 3 |
||
4 3 3 2 1 |
4 3 3 2 1 |
||
bead bead 5 3 1 7 4 1 1 |
bead bead 5 3 1 7 4 1 1 |
||
7 5 4 3 1 1 1</ |
7 5 4 3 1 1 1</syntaxhighlight> |
||
Extending to deal with sequences of arbitrary integers: |
Extending to deal with sequences of arbitrary integers: |
||
< |
<syntaxhighlight lang="j">bball=: ] (] + [: bead^:2 -) <./ - 1:</syntaxhighlight> |
||
Example use: |
Example use: |
||
<lang> bball 2 0 _1 3 1 _2 _3 0 |
<syntaxhighlight lang="text"> bball 2 0 _1 3 1 _2 _3 0 |
||
3 2 1 0 0 _1 _2 _3</ |
3 2 1 0 0 _1 _2 _3</syntaxhighlight> |
||
=={{header|Java}}== |
|||
<syntaxhighlight lang="java"> |
|||
public class BeadSort |
|||
{ |
|||
public static void main(String[] args) |
|||
{ |
|||
BeadSort now=new BeadSort(); |
|||
int[] arr=new int[(int)(Math.random()*11)+5]; |
|||
for(int i=0;i<arr.length;i++) |
|||
arr[i]=(int)(Math.random()*10); |
|||
System.out.print("Unsorted: "); |
|||
now.display1D(arr); |
|||
int[] sort=now.beadSort(arr); |
|||
System.out.print("Sorted: "); |
|||
now.display1D(sort); |
|||
} |
|||
int[] beadSort(int[] arr) |
|||
{ |
|||
int max=a[0]; |
|||
for(int i=1;i<arr.length;i++) |
|||
if(arr[i]>max) |
|||
max=arr[i]; |
|||
//Set up abacus |
|||
char[][] grid=new char[arr.length][max]; |
|||
int[] levelcount=new int[max]; |
|||
for(int i=0;i<max;i++) |
|||
{ |
|||
levelcount[i]=0; |
|||
for(int j=0;j<arr.length;j++) |
|||
grid[j][i]='_'; |
|||
} |
|||
/* |
|||
display1D(arr); |
|||
display1D(levelcount); |
|||
display2D(grid); |
|||
*/ |
|||
//Drop the beads |
|||
for(int i=0;i<arr.length;i++) |
|||
{ |
|||
int num=arr[i]; |
|||
for(int j=0;num>0;j++) |
|||
{ |
|||
grid[levelcount[j]++][j]='*'; |
|||
num--; |
|||
} |
|||
} |
|||
System.out.println(); |
|||
display2D(grid); |
|||
//Count the beads |
|||
int[] sorted=new int[arr.length]; |
|||
for(int i=0;i<arr.length;i++) |
|||
{ |
|||
int putt=0; |
|||
for(int j=0;j<max&&grid[arr.length-1-i][j]=='*';j++) |
|||
putt++; |
|||
sorted[i]=putt; |
|||
} |
|||
return sorted; |
|||
} |
|||
void display1D(int[] arr) |
|||
{ |
|||
for(int i=0;i<arr.length;i++) |
|||
System.out.print(arr[i]+" "); |
|||
System.out.println(); |
|||
} |
|||
void display1D(char[] arr) |
|||
{ |
|||
for(int i=0;i<arr.length;i++) |
|||
System.out.print(arr[i]+" "); |
|||
System.out.println(); |
|||
} |
|||
void display2D(char[][] arr) |
|||
{ |
|||
for(int i=0;i<arr.length;i++) |
|||
display1D(arr[i]); |
|||
System.out.println(); |
|||
} |
|||
} |
|||
</syntaxhighlight> |
|||
{{out}} |
|||
<pre> |
|||
Unsorted: 9 4 7 0 4 3 0 5 3 8 7 9 8 7 0 |
|||
* * * * * * * * * |
|||
* * * * * * * * * |
|||
* * * * * * * * _ |
|||
* * * * * * * * _ |
|||
* * * * * * * _ _ |
|||
* * * * * * * _ _ |
|||
* * * * * * * _ _ |
|||
* * * * * _ _ _ _ |
|||
* * * * _ _ _ _ _ |
|||
* * * * _ _ _ _ _ |
|||
* * * _ _ _ _ _ _ |
|||
* * * _ _ _ _ _ _ |
|||
_ _ _ _ _ _ _ _ _ |
|||
_ _ _ _ _ _ _ _ _ |
|||
_ _ _ _ _ _ _ _ _ |
|||
Sorted: 0 0 0 3 3 4 4 5 7 7 7 8 8 9 9 |
|||
</pre> |
|||
=={{header|jq}}== |
|||
'''Part 1: The abacus''' |
|||
This implementation uses an "abacus" as described in the Wikipedia article. |
|||
However, rather than representing each row as a set of n beads, it suffices |
|||
to use the integer n instead. Thus the initial state of our abacus |
|||
is simply the array of numbers to be sorted. (A better approach would be to normalize the integers by subtracting their minimum value minus 1; that would also allow sorting arrays of integers without restriction.) |
|||
'''Part 2: Gravity''' |
|||
<syntaxhighlight lang="jq"># ncols is the number of columns (i.e. vertical poles) |
|||
def column_sums(ncols): |
|||
. as $abacus |
|||
| reduce range(0; ncols) as $col |
|||
([]; |
|||
. + [reduce $abacus[] as $row |
|||
(0; if $row > $col then .+1 else . end)]) ;</syntaxhighlight> |
|||
'''Part 3: read the answer in order of largest-to-smallest''' |
|||
<syntaxhighlight lang="jq"># Generic function to count the number of items in a stream: |
|||
def count(stream): reduce stream as $i (0; .+1); |
|||
def readout: |
|||
. as $sums |
|||
| .[0] as $n |
|||
| reduce range(0;$n) as $i |
|||
([]; . + [count( $sums[] | select( . > $i) )]);</syntaxhighlight> |
|||
'''"Bead Sort":''' |
|||
<syntaxhighlight lang="jq">def bead_sort: column_sums(max) | readout;</syntaxhighlight> |
|||
'''Example:''' |
|||
<syntaxhighlight lang="jq">[734,3,1,24,324,324,32,432,42,3,4,1,1] | bead_sort</syntaxhighlight> |
|||
{{out}} |
|||
<syntaxhighlight lang="sh">$ jq -n -c -f bead_sort.jq |
|||
[734,432,324,324,42,32,24,4,3,3,1,1,1]</syntaxhighlight> |
|||
=={{header|Julia}}== |
|||
{{works with|Julia|0.6}} |
|||
Implement <code>beadsort</code> on a <code>BitArray</code> ''abacus''. The function should work for any integer type. It throws a <code>DomainError</code> if the input array contains a non-positive integer. |
|||
<syntaxhighlight lang="julia">function beadsort(a::Vector{<:Integer}) |
|||
lo, hi = extrema(a) |
|||
if lo < 1 throw(DomainError()) end |
|||
len = length(a) |
|||
abacus = falses(len, hi) |
|||
for (i, v) in enumerate(a) |
|||
abacus[i, 1:v] = true |
|||
end |
|||
for i in 1:hi |
|||
v = sum(abacus[:, i]) |
|||
if v < len |
|||
abacus[1:end-v, i] = false |
|||
abacus[end-v+1:end, i] = true |
|||
end |
|||
end |
|||
return collect(eltype(a), sum(abacus[i,:]) for i in 1:len) |
|||
end |
|||
v = rand(UInt8, 20) |
|||
println("# unsorted bytes: $v\n -> sorted bytes: $(beadsort(v))") |
|||
v = rand(1:2 ^ 10, 20) |
|||
println("# unsorted integers: $v\n -> sorted integers: $(beadsort(v))")</syntaxhighlight> |
|||
{{out}} |
|||
<pre># unsorted bytes: UInt8[0xff, 0x52, 0xdd, 0x72, 0xe2, 0x13, 0xb5, 0xd3, 0x7f, 0xea, 0x3b, 0x46, 0x4b, 0x78, 0xfb, 0xbe, 0xd8, 0x2e, 0xa9, 0x7a] |
|||
-> sorted bytes: UInt8[0x13, 0x2e, 0x3b, 0x46, 0x4b, 0x52, 0x72, 0x78, 0x7a, 0x7f, 0xa9, 0xb5, 0xbe, 0xd3, 0xd8, 0xdd, 0xe2, 0xea, 0xfb, 0xff] |
|||
# unsorted integers: [1012, 861, 798, 949, 481, 889, 78, 699, 718, 195, 426, 922, 762, 360, 1017, 208, 304, 13, 910, 854] |
|||
-> sorted integers: [13, 78, 195, 208, 304, 360, 426, 481, 699, 718, 762, 798, 854, 861, 889, 910, 922, 949, 1012, 1017]</pre> |
|||
=={{header|Kotlin}}== |
|||
{{trans|C}} |
|||
<syntaxhighlight lang="scala">// version 1.1.2 |
|||
fun beadSort(a: IntArray) { |
|||
val n = a.size |
|||
if (n < 2) return |
|||
var max = a.max()!! |
|||
val beads = ByteArray(max * n) |
|||
/* mark the beads */ |
|||
for (i in 0 until n) |
|||
for (j in 0 until a[i]) |
|||
beads[i * max + j] = 1 |
|||
for (j in 0 until max) { |
|||
/* count how many beads are on each post */ |
|||
var sum = 0 |
|||
for (i in 0 until n) { |
|||
sum += beads[i * max + j] |
|||
beads[i * max + j] = 0 |
|||
} |
|||
/* mark bottom sum beads */ |
|||
for (i in n - sum until n) beads[i * max + j] = 1 |
|||
} |
|||
for (i in 0 until n) { |
|||
var j = 0 |
|||
while (j < max && beads[i * max + j] == 1.toByte()) j++ |
|||
a[i] = j |
|||
} |
|||
} |
|||
fun main(args: Array<String>) { |
|||
val a = intArrayOf(5, 3, 1, 7, 4, 1, 1, 20) |
|||
println("Before sorting : ${a.contentToString()}") |
|||
beadSort(a) |
|||
println("After sorting : ${a.contentToString()}") |
|||
}</syntaxhighlight> |
|||
{{out}} |
|||
<pre> |
|||
Before sorting : [5, 3, 1, 7, 4, 1, 1, 20] |
|||
After sorting : [1, 1, 1, 3, 4, 5, 7, 20] |
|||
</pre> |
|||
=={{header|Lua}}== |
|||
<syntaxhighlight lang="lua">-- Display message followed by all values of a table in one line |
|||
function show (msg, t) |
|||
io.write(msg .. ":\t") |
|||
for _, v in pairs(t) do io.write(v .. " ") end |
|||
print() |
|||
end |
|||
-- Return a table of random numbers |
|||
function randList (length, lo, hi) |
|||
local t = {} |
|||
for i = 1, length do table.insert(t, math.random(lo, hi)) end |
|||
return t |
|||
end |
|||
-- Count instances of numbers that appear in counting to each list value |
|||
function tally (list) |
|||
local tal = {} |
|||
for k, v in pairs(list) do |
|||
for i = 1, v do |
|||
if tal[i] then tal[i] = tal[i] + 1 else tal[i] = 1 end |
|||
end |
|||
end |
|||
return tal |
|||
end |
|||
-- Sort a table of positive integers into descending order |
|||
function beadSort (numList) |
|||
show("Before sort", numList) |
|||
local abacus = tally(numList) |
|||
show("Tally list", abacus) |
|||
local sorted = tally(abacus) |
|||
show("After sort", sorted) |
|||
end |
|||
-- Main procedure |
|||
math.randomseed(os.time()) |
|||
beadSort(randList(10, 1, 10))</syntaxhighlight> |
|||
{{out}} |
|||
<pre>Before sort: 9 5 3 9 4 1 3 8 1 2 |
|||
Tally list: 10 8 7 5 4 3 3 3 2 |
|||
After sort: 9 9 8 5 4 3 3 2 1 1</pre> |
|||
=={{header|Mathematica}}/{{header|Wolfram Language}}== |
|||
<syntaxhighlight lang="mathematica">beadsort[ a ] := Module[ { m, sorted, s ,t }, |
|||
sorted = a; m = Max[a]; t=ConstantArray[0, {m,m} ]; |
|||
If[ Min[a] < 0, Print["can't sort"]]; |
|||
For[ i = 1, i < Length[a], i++, t[[i,1;;a[[i]]]]=1 ] |
|||
For[ i = 1 ,i <= m, i++, s = Total[t[[;;,i]]]; |
|||
t[[ ;; , i]] = 0; t[[1 ;; s , i]] = 1; ] |
|||
For[ i=1,i<=Length[a],i++, sorted[[i]] = Total[t[[i,;;]]]; ] |
|||
Print[sorted]; |
|||
] |
|||
beadsort[{2,1,5,3,6}]</syntaxhighlight> |
|||
{{out}} |
|||
<pre>{6,3,2,1,0}</pre> |
|||
=={{header|NetRexx}}== |
|||
<syntaxhighlight lang="netrexx">/* NetRexx */ |
|||
options replace format comments java crossref symbols nobinary |
|||
runSample(arg) |
|||
return |
|||
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
|||
method bead_sort(harry = Rexx[]) public static binary returns Rexx[] |
|||
MIN_ = 'MIN' |
|||
MAX_ = 'MAX' |
|||
beads = Rexx 0 |
|||
beads[MIN_] = 0 |
|||
beads[MAX_] = 0 |
|||
loop val over harry |
|||
-- collect occurences of beads in indexed string indexed on value |
|||
if val < beads[MIN_] then beads[MIN_] = val -- keep track of min value |
|||
if val > beads[MAX_] then beads[MAX_] = val -- keep track of max value |
|||
beads[val] = beads[val] + 1 |
|||
end val |
|||
harry_sorted = Rexx[harry.length] |
|||
bi = 0 |
|||
loop xx = beads[MIN_] to beads[MAX_] |
|||
-- extract beads in value order and insert in result array |
|||
if beads[xx] == 0 then iterate xx |
|||
loop for beads[xx] |
|||
harry_sorted[bi] = xx |
|||
bi = bi + 1 |
|||
end |
|||
end xx |
|||
return harry_sorted |
|||
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
|||
method runSample(arg) public static |
|||
unsorted = [734, 3, 1, 24, 324, -1024, -666, -1, 0, 324, 32, 0, 432, 42, 3, 4, 1, 1] |
|||
sorted = bead_sort(unsorted) |
|||
say arrayToString(unsorted) |
|||
say arrayToString(sorted) |
|||
return |
|||
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
|||
method arrayToString(harry = Rexx[]) private static |
|||
list = Rexx '' |
|||
loop vv over harry |
|||
list = list vv |
|||
end vv |
|||
return '['list.space(1, ',')']' |
|||
</syntaxhighlight> |
|||
{{out}} |
|||
<pre> |
|||
[734,3,1,24,324,-1024,-666,-1,0,324,32,0,432,42,3,4,1,1] |
|||
[-1024,-666,-1,0,0,1,1,1,3,3,4,24,32,42,324,324,432,734] |
|||
</pre> |
|||
=={{header|Nim}}== |
|||
<syntaxhighlight lang="nim">proc beadSort[T](a: var openarray[T]) = |
|||
var max = low(T) |
|||
var sum = 0 |
|||
for x in a: |
|||
if x > max: max = x |
|||
var beads = newSeq[int](max * a.len) |
|||
for i in 0 ..< a.len: |
|||
for j in 0 ..< a[i]: |
|||
beads[i * max + j] = 1 |
|||
for j in 0 ..< max: |
|||
sum = 0 |
|||
for i in 0 ..< a.len: |
|||
sum += beads[i * max + j] |
|||
beads[i * max + j] = 0 |
|||
for i in a.len - sum ..< a.len: |
|||
beads[i * max + j] = 1 |
|||
for i in 0 ..< a.len: |
|||
var j = 0 |
|||
while j < max and beads[i * max + j] > 0: inc j |
|||
a[i] = j |
|||
var a = @[5, 3, 1, 7, 4, 1, 1, 20] |
|||
beadSort a |
|||
echo a</syntaxhighlight> |
|||
{{out}} |
|||
<pre>@[1, 1, 1, 3, 4, 5, 7, 20]</pre> |
|||
=={{header|OCaml}}== |
|||
{{trans|Haskell}} |
|||
<syntaxhighlight lang="ocaml">let rec columns l = |
|||
match List.filter ((<>) []) l with |
|||
[] -> [] |
|||
| l -> List.map List.hd l :: columns (List.map List.tl l) |
|||
let replicate n x = Array.to_list (Array.make n x) |
|||
let bead_sort l = |
|||
List.map List.length (columns (columns (List.map (fun e -> replicate e 1) l)))</syntaxhighlight> |
|||
usage |
|||
<pre> |
|||
# bead_sort [5;3;1;7;4;1;1];; |
|||
- : int list = [7; 5; 4; 3; 1; 1; 1] |
|||
</pre> |
|||
=={{header|Octave}}== |
=={{header|Octave}}== |
||
{{trans|Fortran}} |
{{trans|Fortran}} |
||
< |
<syntaxhighlight lang="octave">function sorted = beadsort(a) |
||
sorted = a; |
sorted = a; |
||
m = max(a); |
m = max(a); |
||
Line 475: | Line 2,020: | ||
endfunction |
endfunction |
||
beadsort([5, 7, 1, 3, 1, 1, 20])</ |
beadsort([5, 7, 1, 3, 1, 1, 20])</syntaxhighlight> |
||
=={{header|ooRexx}}== |
|||
===version 1=== |
|||
<syntaxhighlight lang="oorexx">in='10 -12 1 0 999 8 2 2 4 4' |
|||
Do i=1 To words(in) |
|||
z.i=word(in,i) |
|||
End |
|||
n=i-1 |
|||
init=0 |
|||
Call minmax |
|||
beads.=0; |
|||
Do i=1 To words(in) |
|||
z=z.i |
|||
beads.z+=1 |
|||
End |
|||
j=0 |
|||
Do i=lo To hi |
|||
Do While beads.i>0 |
|||
j+=1 |
|||
s.j=i |
|||
beads.i-=1 |
|||
End; |
|||
End; |
|||
Call show ' Input:',z.,n |
|||
Call show 'Sorted:',s.,n |
|||
Exit |
|||
minmax: |
|||
Do i=1 To n |
|||
If init=0 Then Do |
|||
init=1 |
|||
lo=z.i |
|||
hi=z.i |
|||
End |
|||
Else Do |
|||
lo=min(lo,z.i) |
|||
hi=max(hi,z.i) |
|||
End |
|||
End |
|||
Return |
|||
show: Procedure Expose n |
|||
Use Arg txt,a. |
|||
ol=txtg> |
|||
Do i=1 To n |
|||
ol=ol format(a.i,3) |
|||
End |
|||
Say ol |
|||
Return </syntaxhighlight> |
|||
{{out}} |
|||
<pre> Input: 10 -12 1 0 999 8 2 2 4 4 |
|||
Sorted: -12 0 1 2 2 4 4 8 10 999</pre> |
|||
===version 2=== |
|||
{{trans|REXX}} |
|||
'''Note:''' The only changes needed were to substitute '''<tt>_</tt>''', '''<tt>!</tt>''' and '''<tt>?</tt>''' characters for the "deprecated" <tt>'''$'''</tt>, <tt>'''#'''</tt> and '''<tt>@</tt>''' characters within variable names; as per <cite>The REXX Language, Second Edition</cite> by M. F. Cowlishaw. (See a description [http://www.rexxla.org/rexxlang/mfc/trl.html here]). |
|||
<syntaxhighlight lang="oorexx">/*REXX program sorts a list of integers using a bead sort. */ |
|||
/*get some grassHopper numbers. */ |
|||
grasshopper=, |
|||
1 4 10 12 22 26 30 46 54 62 66 78 94 110 126 134 138 158 162 186 190 222 254 270 |
|||
/*GreeenGrocer numbers are also called hexagonal pyramidal */ |
|||
/* numbers. */ |
|||
greengrocer=, |
|||
0 4 16 40 80 140 224 336 480 660 880 1144 1456 1820 2240 2720 3264 3876 4560 |
|||
/*get some Bernoulli numerator numbers. */ |
|||
bernN='1 -1 1 0 -1 0 1 0 -1 0 5 0 -691 0 7 0 -3617 0 43867 0 -174611 0 854513' |
|||
/*Psi is also called the Reduced Totient function, and */ |
|||
/* is also called Carmichale lambda, or LAMBDA function.*/ |
|||
psi=, |
|||
1 1 2 2 4 2 6 2 6 4 10 2 12 6 4 4 16 6 18 4 6 10 22 2 20 12 18 6 28 4 30 8 10 16 |
|||
list=grasshopper greengrocer bernN psi /*combine the four lists into one*/ |
|||
call showL 'before sort',list /*show list before sorting. */ |
|||
!=beadSort(list) /*invoke the bead sort. */ |
|||
call showL ' after sort',! /*show after array elements*/ |
|||
exit |
|||
/*─────────────────────────────────beadSort@ subroutine────────────*/ |
|||
beadSort: procedure expose _. |
|||
parse arg z |
|||
!='' /*this'll be the sorted list*/ |
|||
low=999999999; high=-low /*define the low and high #s*/ |
|||
_.=0 /*define all beads to zero. */ |
|||
do j=1 until z=='' /*pick the meat off the bone*/ |
|||
parse var z x z |
|||
if \datatype(x,'Whole') then |
|||
do |
|||
say |
|||
say '*** error! ***' |
|||
say |
|||
say 'element' j "in list isn't numeric:" x |
|||
say |
|||
exit 13 |
|||
end |
|||
x=x/1 /*normalize number, it could*/ |
|||
/*be: +4 007 5. 2e3 etc.*/ |
|||
_.x=_.x+1 /*indicate this bead has a #*/ |
|||
low=min(low,x) /*keep track of the lowest #*/ |
|||
high=max(high,x) /* " " " " highest#*/ |
|||
end j |
|||
/*now, collect the beads and*/ |
|||
do m=low to high /*let them fall (to zero). */ |
|||
if _.m==0 then iterate /*No bead here? Keep looking*/ |
|||
do n=1 for _.m /*let the beads fall to 0. */ |
|||
!=! m /*add it to the sorted list.*/ |
|||
end n |
|||
end m |
|||
return ! |
|||
/*─────────────────────────────────────SHOW@ subroutine────────────*/ |
|||
showL: |
|||
widthH=length(words(arg(2))) /*maximum width of the index*/ |
|||
do j=1 for words(arg(2)) |
|||
say 'element' right(j,widthH) arg(1)":" right(word(arg(2),j),10) |
|||
end j |
|||
say copies('─',80) /*show a separator line. */ |
|||
return |
|||
</syntaxhighlight> |
|||
{{out}} |
|||
<pre style="height:30ex;overflow:scroll"> |
|||
element 1 before sort: 1 |
|||
element 2 before sort: 4 |
|||
element 3 before sort: 10 |
|||
element 4 before sort: 12 |
|||
element 5 before sort: 22 |
|||
element 6 before sort: 26 |
|||
element 7 before sort: 30 |
|||
element 8 before sort: 46 |
|||
element 9 before sort: 54 |
|||
element 10 before sort: 62 |
|||
element 11 before sort: 66 |
|||
element 12 before sort: 78 |
|||
element 13 before sort: 94 |
|||
element 14 before sort: 110 |
|||
element 15 before sort: 126 |
|||
element 16 before sort: 134 |
|||
element 17 before sort: 138 |
|||
element 18 before sort: 158 |
|||
element 19 before sort: 162 |
|||
element 20 before sort: 186 |
|||
element 21 before sort: 190 |
|||
element 22 before sort: 222 |
|||
element 23 before sort: 254 |
|||
element 24 before sort: 270 |
|||
element 25 before sort: 0 |
|||
element 26 before sort: 4 |
|||
element 27 before sort: 16 |
|||
element 28 before sort: 40 |
|||
element 29 before sort: 80 |
|||
element 30 before sort: 140 |
|||
element 31 before sort: 224 |
|||
element 32 before sort: 336 |
|||
element 33 before sort: 480 |
|||
element 34 before sort: 660 |
|||
element 35 before sort: 880 |
|||
element 36 before sort: 1144 |
|||
element 37 before sort: 1456 |
|||
element 38 before sort: 1820 |
|||
element 39 before sort: 2240 |
|||
element 40 before sort: 2720 |
|||
element 41 before sort: 3264 |
|||
element 42 before sort: 3876 |
|||
element 43 before sort: 4560 |
|||
element 44 before sort: 1 |
|||
element 45 before sort: -1 |
|||
element 46 before sort: 1 |
|||
element 47 before sort: 0 |
|||
element 48 before sort: -1 |
|||
element 49 before sort: 0 |
|||
element 50 before sort: 1 |
|||
element 51 before sort: 0 |
|||
element 52 before sort: -1 |
|||
element 53 before sort: 0 |
|||
element 54 before sort: 5 |
|||
element 55 before sort: 0 |
|||
element 56 before sort: -691 |
|||
element 57 before sort: 0 |
|||
element 58 before sort: 7 |
|||
element 59 before sort: 0 |
|||
element 60 before sort: -3617 |
|||
element 61 before sort: 0 |
|||
element 62 before sort: 43867 |
|||
element 63 before sort: 0 |
|||
element 64 before sort: -174611 |
|||
element 65 before sort: 0 |
|||
element 66 before sort: 854513 |
|||
element 67 before sort: 1 |
|||
element 68 before sort: 1 |
|||
element 69 before sort: 2 |
|||
element 70 before sort: 2 |
|||
element 71 before sort: 4 |
|||
element 72 before sort: 2 |
|||
element 73 before sort: 6 |
|||
element 74 before sort: 2 |
|||
element 75 before sort: 6 |
|||
element 76 before sort: 4 |
|||
element 77 before sort: 10 |
|||
element 78 before sort: 2 |
|||
element 79 before sort: 12 |
|||
element 80 before sort: 6 |
|||
element 81 before sort: 4 |
|||
element 82 before sort: 4 |
|||
element 83 before sort: 16 |
|||
element 84 before sort: 6 |
|||
element 85 before sort: 18 |
|||
element 86 before sort: 4 |
|||
element 87 before sort: 6 |
|||
element 88 before sort: 10 |
|||
element 89 before sort: 22 |
|||
element 90 before sort: 2 |
|||
element 91 before sort: 20 |
|||
element 92 before sort: 12 |
|||
element 93 before sort: 18 |
|||
element 94 before sort: 6 |
|||
element 95 before sort: 28 |
|||
element 96 before sort: 4 |
|||
element 97 before sort: 30 |
|||
element 98 before sort: 8 |
|||
element 99 before sort: 10 |
|||
element 100 before sort: 16 |
|||
──────────────────────────────────────────────────────────────────────────────── |
|||
element 1 after sort: -174611 |
|||
element 2 after sort: -3617 |
|||
element 3 after sort: -691 |
|||
element 4 after sort: -1 |
|||
element 5 after sort: -1 |
|||
element 6 after sort: -1 |
|||
element 7 after sort: 0 |
|||
element 8 after sort: 0 |
|||
element 9 after sort: 0 |
|||
element 10 after sort: 0 |
|||
element 11 after sort: 0 |
|||
element 12 after sort: 0 |
|||
element 13 after sort: 0 |
|||
element 14 after sort: 0 |
|||
element 15 after sort: 0 |
|||
element 16 after sort: 0 |
|||
element 17 after sort: 0 |
|||
element 18 after sort: 1 |
|||
element 19 after sort: 1 |
|||
element 20 after sort: 1 |
|||
element 21 after sort: 1 |
|||
element 22 after sort: 1 |
|||
element 23 after sort: 1 |
|||
element 24 after sort: 2 |
|||
element 25 after sort: 2 |
|||
element 26 after sort: 2 |
|||
element 27 after sort: 2 |
|||
element 28 after sort: 2 |
|||
element 29 after sort: 2 |
|||
element 30 after sort: 4 |
|||
element 31 after sort: 4 |
|||
element 32 after sort: 4 |
|||
element 33 after sort: 4 |
|||
element 34 after sort: 4 |
|||
element 35 after sort: 4 |
|||
element 36 after sort: 4 |
|||
element 37 after sort: 4 |
|||
element 38 after sort: 5 |
|||
element 39 after sort: 6 |
|||
element 40 after sort: 6 |
|||
element 41 after sort: 6 |
|||
element 42 after sort: 6 |
|||
element 43 after sort: 6 |
|||
element 44 after sort: 6 |
|||
element 45 after sort: 7 |
|||
element 46 after sort: 8 |
|||
element 47 after sort: 10 |
|||
element 48 after sort: 10 |
|||
element 49 after sort: 10 |
|||
element 50 after sort: 10 |
|||
element 51 after sort: 12 |
|||
element 52 after sort: 12 |
|||
element 53 after sort: 12 |
|||
element 54 after sort: 16 |
|||
element 55 after sort: 16 |
|||
element 56 after sort: 16 |
|||
element 57 after sort: 18 |
|||
element 58 after sort: 18 |
|||
element 59 after sort: 20 |
|||
element 60 after sort: 22 |
|||
element 61 after sort: 22 |
|||
element 62 after sort: 26 |
|||
element 63 after sort: 28 |
|||
element 64 after sort: 30 |
|||
element 65 after sort: 30 |
|||
element 66 after sort: 40 |
|||
element 67 after sort: 46 |
|||
element 68 after sort: 54 |
|||
element 69 after sort: 62 |
|||
element 70 after sort: 66 |
|||
element 71 after sort: 78 |
|||
element 72 after sort: 80 |
|||
element 73 after sort: 94 |
|||
element 74 after sort: 110 |
|||
element 75 after sort: 126 |
|||
element 76 after sort: 134 |
|||
element 77 after sort: 138 |
|||
element 78 after sort: 140 |
|||
element 79 after sort: 158 |
|||
element 80 after sort: 162 |
|||
element 81 after sort: 186 |
|||
element 82 after sort: 190 |
|||
element 83 after sort: 222 |
|||
element 84 after sort: 224 |
|||
element 85 after sort: 254 |
|||
element 86 after sort: 270 |
|||
element 87 after sort: 336 |
|||
element 88 after sort: 480 |
|||
element 89 after sort: 660 |
|||
element 90 after sort: 880 |
|||
element 91 after sort: 1144 |
|||
element 92 after sort: 1456 |
|||
element 93 after sort: 1820 |
|||
element 94 after sort: 2240 |
|||
element 95 after sort: 2720 |
|||
element 96 after sort: 3264 |
|||
element 97 after sort: 3876 |
|||
element 98 after sort: 4560 |
|||
element 99 after sort: 43867 |
|||
element 100 after sort: 854513 |
|||
──────────────────────────────────────────────────────────────────────────────── |
|||
</pre> |
|||
=={{header|OpenEdge/Progress}}== |
=={{header|OpenEdge/Progress}}== |
||
Sorting algorithms are not the kind of thing you need / want to do in OpenEdge. If you want to sort simply define a temp-table with one field, populate it and get sorted results with FOR EACH temp-table DESCENDING. |
Sorting algorithms are not the kind of thing you need / want to do in OpenEdge. If you want to sort simply define a temp-table with one field, populate it and get sorted results with FOR EACH temp-table DESCENDING. |
||
< |
<syntaxhighlight lang="openedge/progress">FUNCTION beadSort RETURNS CHAR ( |
||
i_c AS CHAR |
i_c AS CHAR |
||
): |
): |
||
Line 529: | Line 2,420: | ||
"5,3,1,7,4,1,1 -> " beadSort( "5,3,1,7,4,1,1" ) SKIP(1) |
"5,3,1,7,4,1,1 -> " beadSort( "5,3,1,7,4,1,1" ) SKIP(1) |
||
beadSort( "88,18,31,44,4,0,8,81,14,78,20,76,84,33,73,75,82,5,62,70,12,7,1" ) |
beadSort( "88,18,31,44,4,0,8,81,14,78,20,76,84,33,73,75,82,5,62,70,12,7,1" ) |
||
VIEW-AS ALERT-BOX.</ |
VIEW-AS ALERT-BOX.</syntaxhighlight> |
||
{{out}} |
|||
Output: |
|||
<pre>--------------------------- |
<pre>--------------------------- |
||
Message |
Message |
||
Line 544: | Line 2,435: | ||
=={{header|PARI/GP}}== |
=={{header|PARI/GP}}== |
||
This implementation uses the counting sort to order the beads in a given row. |
This implementation uses the counting sort to order the beads in a given row. |
||
< |
<syntaxhighlight lang="parigp">beadsort(v)={ |
||
my(sz=vecmax(v),M=matrix(#v,sz,i,j,v[i]>=j)); \\ Set up beads |
my(sz=vecmax(v),M=matrix(#v,sz,i,j,v[i]>=j)); \\ Set up beads |
||
for(i=1,sz,M[,i]=countingSort(M[,i],0,1)~); \\ Let them fall |
for(i=1,sz,M[,i]=countingSort(M[,i],0,1)~); \\ Let them fall |
||
Line 567: | Line 2,458: | ||
); |
); |
||
left |
left |
||
};</ |
};</syntaxhighlight> |
||
=={{header|Pascal}}== |
|||
<syntaxhighlight lang="pascal"> |
|||
program BDS; |
|||
const MAX = 1000; |
|||
type |
|||
type_matrix = record |
|||
lin,col:integer; |
|||
matrix: array [1..MAX,1..MAX] of boolean; |
|||
end; |
|||
type_vector = record |
|||
size:integer; |
|||
vector: array[1..MAX] of integer; |
|||
end; |
|||
procedure BeadSort(var v:type_vector); |
|||
var |
|||
i,j,k,sum:integer; |
|||
m:type_matrix; |
|||
begin |
|||
m.lin:=v.size; |
|||
(* the number of columns is equal to the greatest element *) |
|||
m.col:=0; |
|||
for i:=1 to v.size do |
|||
if v.vector[i] > m.col then |
|||
m.col:=v.vector[i]; |
|||
(* initializing the matrix *) |
|||
for j:=1 to m.lin do |
|||
begin |
|||
k:=1; |
|||
for i:=m.col downto 1 do |
|||
begin |
|||
if v.vector[j] >= k then |
|||
m.matrix[i,j]:=TRUE |
|||
else |
|||
m.matrix[i,j]:=FALSE; |
|||
k:=k+1; |
|||
end; |
|||
end; |
|||
(* Sort the matrix *) |
|||
for i:=1 to m.col do |
|||
begin |
|||
(* Count the beads and set the line equal FALSE *) |
|||
sum:=0; |
|||
for j:=1 to m.lin do |
|||
begin |
|||
if m.matrix[i,j] then |
|||
sum:=sum+1; |
|||
m.matrix[i,j]:=FALSE; |
|||
end; |
|||
(* The line receives the bead sorted *) |
|||
for j:=m.lin downto m.lin-sum+1 do |
|||
m.matrix[i,j]:=TRUE; |
|||
end; |
|||
(* Convert the sorted bead matrix to a sorted vector *) |
|||
for j:=1 to m.lin do |
|||
begin |
|||
v.vector[j]:=0; |
|||
i:=m.col; |
|||
while (m.matrix[i,j] = TRUE)and(i>=1) do |
|||
begin |
|||
v.vector[j]+=1; |
|||
i:=i-1; |
|||
end; |
|||
end; |
|||
end; |
|||
procedure print_vector(var v:type_vector); |
|||
var i:integer; |
|||
begin |
|||
for i:=1 to v.size do |
|||
write(v.vector[i],' '); |
|||
writeln; |
|||
end; |
|||
var |
|||
i:integer; |
|||
v:type_vector; |
|||
begin |
|||
writeln('How many numbers do you want to sort?'); |
|||
readln(v.size); |
|||
writeln('Write the numbers:'); |
|||
for i:=1 to v.size do |
|||
read(v.vector[i]); |
|||
writeln('Before sort:'); |
|||
print_vector(v); |
|||
BeadSort(v); |
|||
writeln('After sort:'); |
|||
print_vector(v); |
|||
end. |
|||
</syntaxhighlight> |
|||
{{out}} |
|||
<pre> |
|||
How many numbers do you want to sort? |
|||
10 |
|||
Write the numbers: |
|||
23 13 99 45 26 7 63 214 87 45 |
|||
Before sort: |
|||
23 13 99 45 26 7 63 214 87 45 |
|||
After sort: |
|||
7 13 23 26 45 45 63 87 99 214 |
|||
</pre> |
|||
=={{header|Perl}}== |
=={{header|Perl}}== |
||
Instead of storing the bead matrix explicitly, I choose to store just the number of beads in each row and column, compacting on the fly. At all times, the sum of the row widths is equal to the sum column heights. |
Instead of storing the bead matrix explicitly, I choose to store just the number of beads in each row and column, compacting on the fly. At all times, the sum of the row widths is equal to the sum column heights. |
||
< |
<syntaxhighlight lang="perl">sub beadsort { |
||
my @data = @_; |
my @data = @_; |
||
Line 588: | Line 2,593: | ||
beadsort 5, 7, 1, 3, 1, 1, 20; |
beadsort 5, 7, 1, 3, 1, 1, 20; |
||
</syntaxhighlight> |
|||
</lang> |
|||
=={{header| |
=={{header|Phix}}== |
||
<!--<syntaxhighlight lang="phix">(phixonline)--> |
|||
<span style="color: #008080;">with</span> <span style="color: #008080;">javascript_semantics</span> |
|||
<span style="color: #008080;">function</span> <span style="color: #000000;">beadsort</span><span style="color: #0000FF;">(</span><span style="color: #004080;">sequence</span> <span style="color: #000000;">a</span><span style="color: #0000FF;">)</span> |
|||
<span style="color: #004080;">sequence</span> <span style="color: #000000;">poles</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">repeat</span><span style="color: #0000FF;">(</span><span style="color: #000000;">0</span><span style="color: #0000FF;">,</span><span style="color: #7060A8;">max</span><span style="color: #0000FF;">(</span><span style="color: #000000;">a</span><span style="color: #0000FF;">))</span> |
|||
<span style="color: #008080;">for</span> <span style="color: #000000;">i</span><span style="color: #0000FF;">=</span><span style="color: #000000;">1</span> <span style="color: #008080;">to</span> <span style="color: #7060A8;">length</span><span style="color: #0000FF;">(</span><span style="color: #000000;">a</span><span style="color: #0000FF;">)</span> <span style="color: #008080;">do</span> |
|||
<span style="color: #000000;">poles</span><span style="color: #0000FF;">[</span><span style="color: #000000;">1</span><span style="color: #0000FF;">..</span><span style="color: #000000;">a</span><span style="color: #0000FF;">[</span><span style="color: #000000;">i</span><span style="color: #0000FF;">]]</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">sq_add</span><span style="color: #0000FF;">(</span><span style="color: #000000;">poles</span><span style="color: #0000FF;">[</span><span style="color: #000000;">1</span><span style="color: #0000FF;">..</span><span style="color: #000000;">a</span><span style="color: #0000FF;">[</span><span style="color: #000000;">i</span><span style="color: #0000FF;">]],</span><span style="color: #000000;">1</span><span style="color: #0000FF;">)</span> |
|||
<span style="color: #008080;">end</span> <span style="color: #008080;">for</span> |
|||
<span style="color: #000000;">a</span><span style="color: #0000FF;">[</span><span style="color: #000000;">1</span><span style="color: #0000FF;">..$]</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">0</span> |
|||
<span style="color: #008080;">for</span> <span style="color: #000000;">i</span><span style="color: #0000FF;">=</span><span style="color: #000000;">1</span> <span style="color: #008080;">to</span> <span style="color: #7060A8;">length</span><span style="color: #0000FF;">(</span><span style="color: #000000;">poles</span><span style="color: #0000FF;">)</span> <span style="color: #008080;">do</span> |
|||
<span style="color: #000000;">a</span><span style="color: #0000FF;">[</span><span style="color: #000000;">1</span><span style="color: #0000FF;">..</span><span style="color: #000000;">poles</span><span style="color: #0000FF;">[</span><span style="color: #000000;">i</span><span style="color: #0000FF;">]]</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">sq_add</span><span style="color: #0000FF;">(</span><span style="color: #000000;">a</span><span style="color: #0000FF;">[</span><span style="color: #000000;">1</span><span style="color: #0000FF;">..</span><span style="color: #000000;">poles</span><span style="color: #0000FF;">[</span><span style="color: #000000;">i</span><span style="color: #0000FF;">]],</span><span style="color: #000000;">1</span><span style="color: #0000FF;">)</span> |
|||
<span style="color: #008080;">end</span> <span style="color: #008080;">for</span> |
|||
<span style="color: #008080;">return</span> <span style="color: #000000;">a</span> |
|||
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span> |
|||
<span style="color: #0000FF;">?</span><span style="color: #000000;">beadsort</span><span style="color: #0000FF;">({</span><span style="color: #000000;">5</span><span style="color: #0000FF;">,</span> <span style="color: #000000;">3</span><span style="color: #0000FF;">,</span> <span style="color: #000000;">1</span><span style="color: #0000FF;">,</span> <span style="color: #000000;">7</span><span style="color: #0000FF;">,</span> <span style="color: #000000;">4</span><span style="color: #0000FF;">,</span> <span style="color: #000000;">1</span><span style="color: #0000FF;">,</span> <span style="color: #000000;">1</span><span style="color: #0000FF;">,</span> <span style="color: #000000;">20</span><span style="color: #0000FF;">})</span> |
|||
<!--</syntaxhighlight>--> |
|||
{{out}} |
|||
<pre> |
|||
{20,7,5,4,3,1,1,1} |
|||
</pre> |
|||
=={{header|PHP}}== |
|||
{{trans|Haskell}} |
{{trans|Haskell}} |
||
<syntaxhighlight lang="php"><?php |
|||
<lang perl6>use List::Utils; |
|||
function columns($arr) { |
|||
if (count($arr) == 0) |
|||
return array(); |
|||
else if (count($arr) == 1) |
|||
return array_chunk($arr[0], 1); |
|||
array_unshift($arr, NULL); |
|||
sub beadsort(@l) { |
|||
// array_map(NULL, $arr[0], $arr[1], ...) |
|||
(transpose(transpose(map {[1 xx $_]}, @l))).map(*.elems); |
|||
$transpose = call_user_func_array('array_map', $arr); |
|||
return array_map('array_filter', $transpose); |
|||
} |
} |
||
function beadsort($arr) { |
|||
my @list = 2,1,3,5; |
|||
foreach ($arr as $e) |
|||
say beadsort(@list).perl;</lang> |
|||
$poles []= array_fill(0, $e, 1); |
|||
return array_map('count', columns(columns($poles))); |
|||
} |
|||
print_r(beadsort(array(5,3,1,7,4,1,1))); |
|||
Output: |
|||
?></syntaxhighlight> |
|||
<pre>(5, 3, 2, 1)</pre> |
|||
{{out}} |
|||
<pre>Array |
|||
( |
|||
[0] => 7 |
|||
[1] => 5 |
|||
[2] => 4 |
|||
[3] => 3 |
|||
[4] => 1 |
|||
[5] => 1 |
|||
[6] => 1 |
|||
)</pre> |
|||
=={{header|PicoLisp}}== |
=={{header|PicoLisp}}== |
||
The following implements a direct model of the bead sort algorithm. |
The following implements a direct model of the bead sort algorithm. |
||
Each pole is a list of 'T' symbols for the beads. |
Each pole is a list of 'T' symbols for the beads. |
||
< |
<syntaxhighlight lang="picolisp">(de beadSort (Lst) |
||
(let Abacus (cons NIL) |
(let Abacus (cons NIL) |
||
(for N Lst # Thread beads on poles |
(for N Lst # Thread beads on poles |
||
Line 615: | Line 2,665: | ||
(make |
(make |
||
(while (gt0 (cnt pop (cdr Abacus))) # Drop and count beads |
(while (gt0 (cnt pop (cdr Abacus))) # Drop and count beads |
||
(link @) ) ) ) )</ |
(link @) ) ) ) )</syntaxhighlight> |
||
{{out}} |
|||
Output: |
|||
<pre>: (beadSort (5 3 1 7 4 1 1 20)) |
<pre>: (beadSort (5 3 1 7 4 1 1 20)) |
||
-> (20 7 5 4 3 1 1 1)</pre> |
-> (20 7 5 4 3 1 1 1)</pre> |
||
=={{header|PL/I}}== |
=={{header|PL/I}}== |
||
===version 1=== |
|||
<lang PL/I> |
|||
<syntaxhighlight lang="pl/i"> |
|||
/* Handles both negative and positive values. */ |
/* Handles both negative and positive values. */ |
||
Line 694: | Line 2,745: | ||
if offset < 0 then z = a + offset; else z = a; |
if offset < 0 then z = a + offset; else z = a; |
||
end beadsort;</ |
end beadsort;</syntaxhighlight> |
||
===version 2=== |
|||
{{trans|ooRexx}} |
|||
PL/I supports negative array indices! |
|||
<syntaxhighlight lang="pli">*process source attributes xref; |
|||
/* Handles both negative and positive values. */ |
|||
Beadsort: Proc Options(main); |
|||
Dcl sysprint Print; |
|||
Dcl (hbound,max,min) Builtin; |
|||
Dcl z(10) Bin Fixed(31) Init(10,-12,1,0,999,8,2,2,4,4); |
|||
Dcl s(10) Bin Fixed(31); |
|||
Dcl (init,lo,hi) Bin Fixed(31) Init(0); |
|||
Dcl (i,j) Bin Fixed(31) Init(0); |
|||
Call minmax(z,init,lo,hi); |
|||
Begin; |
|||
Dcl beads(lo:hi) Bin Fixed(31); |
|||
beads=0; |
|||
Do i=1 To hbound(z); |
|||
beads(z(i))+=1; |
|||
End; |
|||
Do i=lo To hi; |
|||
Do While(beads(i)>0); |
|||
j+=1; |
|||
s(j)=i; |
|||
beads(i)-=1; |
|||
End; |
|||
End; |
|||
Put Edit(' Input:',(z(i) Do i=1 To hbound(z)))(skip,a,99(f(4))); |
|||
Put Edit('Sorted:',(s(i) Do i=1 To hbound(s)))(skip,a,99(f(4))); |
|||
End; |
|||
minmax: Proc(z,init,lo,hi); |
|||
Dcl z(*) Bin Fixed(31); |
|||
Dcl (init,lo,hi) Bin Fixed(31); |
|||
Do i=1 To hbound(z); |
|||
If init=0 Then Do; |
|||
init=1; |
|||
lo,hi=z(i); |
|||
End; |
|||
Else Do; |
|||
lo=min(lo,z(i)); |
|||
hi=max(hi,z(i)); |
|||
End; |
|||
End; |
|||
End; |
|||
End;</syntaxhighlight> |
|||
{{out}} |
|||
<pre> Input: 10 -12 1 0 999 8 2 2 4 4 |
|||
Sorted: -12 0 1 2 2 4 4 8 10 999</pre> |
|||
=={{header|PowerShell}}== |
=={{header|PowerShell}}== |
||
< |
<syntaxhighlight lang="powershell">Function BeadSort ( [Int64[]] $indata ) |
||
{ |
{ |
||
if( $indata.length -gt 1 ) |
if( $indata.length -gt 1 ) |
||
Line 736: | Line 2,840: | ||
} |
} |
||
$l = 100; BeadSort ( 1..$l | ForEach-Object { $Rand = New-Object Random }{ $Rand.Next( -( $l - 1 ), $l - 1 ) } )</ |
$l = 100; BeadSort ( 1..$l | ForEach-Object { $Rand = New-Object Random }{ $Rand.Next( -( $l - 1 ), $l - 1 ) } )</syntaxhighlight> |
||
=={{header|PureBasic}}== |
=={{header|PureBasic}}== |
||
< |
<syntaxhighlight lang="purebasic">#MAXNUM=100 |
||
Dim MyData(Random(15)+5) |
Dim MyData(Random(15)+5) |
||
Line 810: | Line 2,914: | ||
Next |
Next |
||
PrintN(#CRLF$+"And its sum= "+Str(sum)) |
PrintN(#CRLF$+"And its sum= "+Str(sum)) |
||
EndProcedure</ |
EndProcedure</syntaxhighlight> |
||
<pre> |
<pre> |
||
The array is; |
The array is; |
||
Line 821: | Line 2,925: | ||
=={{header|Python}}== |
=={{header|Python}}== |
||
<syntaxhighlight lang="python"> |
|||
{{trans|Haskell}} |
|||
#!/bin/python3 |
|||
<lang python>def beadsort(l): |
|||
from itertools import zip_longest |
|||
return map(len, columns(columns([[1] * e for e in l]))) |
|||
# This is wrong, it works only on specific examples |
|||
def beadsort(l): |
|||
return list(map(sum, zip_longest(*[[1] * e for e in l], fillvalue=0))) |
|||
def columns(l): |
|||
try: |
|||
from itertools import zip_longest |
|||
except: |
|||
zip_longest = lambda *args: map(None, *args) |
|||
return [filter(None, x) for x in zip_longest(*l)] |
|||
# Demonstration code: |
# Demonstration code: |
||
beadsort([5,3,1,7,4,1,1]) |
print(beadsort([5,3,1,7,4,1,1])) |
||
</syntaxhighlight> |
|||
{{out}} |
|||
Output: |
|||
<pre> |
<pre>[7, 5, 4, 3, 1, 1, 1]</pre> |
||
=={{header| |
=={{header|QB64}}== |
||
<syntaxhighlight lang="qb64"> |
|||
The REXX language has the advantage of implenting (true) sparse arrays and with that feature, |
|||
#lang QB64 |
|||
<br> |
|||
'*************************************************** |
|||
implementing a bead sort is trivial, the major drawback is if the spread (difference between |
|||
'* BeadSort is VERY fast for small CGSortLibArray(max)-CGSortLibArray(min). Typical performance is |
|||
<br> |
|||
'* O(NlogN) or better. However as the key values (array values and ranges) go up, the performance |
|||
the lowest and highest values) is quite large. |
|||
'* drops steeply excellent for small-ranged arrays. Integer only at this point. Throughput is |
|||
<br> |
|||
'* roughly 900k/GHzS for double-precision, with binary range (0,1). Related to CountingSort() |
|||
Negative and duplicate numbers (values) are no problem. |
|||
'*************************************************** |
|||
<lang rexx> |
|||
SUB BeadSort (CGSortLibArray() AS DOUBLE, start AS LONG, finish AS LONG, order&) |
|||
/*REXX program sorts a list of integers using a bead sort. */ |
|||
DIM MAX AS DOUBLE: MAX = CGSortLibArray(start) |
|||
DIM BeadSort_Sum AS DOUBLE |
|||
DIM BeadSort_I AS LONG |
|||
DIM BeadSort_J AS LONG |
|||
FOR BeadSort_I = start + 1 TO (finish - start) |
|||
IF (CGSortLibArray(BeadSort_I) > MAX) THEN MAX = CGSortLibArray(BeadSort_I) |
|||
NEXT |
|||
REDIM beads((finish - start), MAX) |
|||
FOR BeadSort_I = 0 TO (finish - start) - 1 |
|||
FOR BeadSort_J = 0 TO CGSortLibArray(BeadSort_I) - 1 |
|||
beads(BeadSort_I, BeadSort_J) = 1 |
|||
NEXT |
|||
NEXT |
|||
IF order& = 1 THEN |
|||
FOR BeadSort_J = 0 TO MAX |
|||
BeadSort_Sum = 0 |
|||
FOR BeadSort_I = 0 TO (finish - start) |
|||
BeadSort_Sum = BeadSort_Sum + beads(BeadSort_I, BeadSort_J) |
|||
beads(BeadSort_I, BeadSort_J) = 0 |
|||
NEXT |
|||
FOR BeadSort_I = (finish - start) - BeadSort_Sum TO (finish - start) |
|||
beads(BeadSort_I, BeadSort_J) = 1 |
|||
NEXT |
|||
NEXT |
|||
FOR BeadSort_I = 0 TO (finish - start) |
|||
BeadSort_J = 0 |
|||
WHILE BeadSort_J < MAX AND beads(BeadSort_I, BeadSort_J) |
|||
BeadSort_J = BeadSort_J + 1 |
|||
WEND |
|||
CGSortLibArray(BeadSort_I) = BeadSort_J |
|||
NEXT |
|||
ELSE |
|||
FOR BeadSort_J = MAX TO 0 STEP -1 |
|||
BeadSort_Sum = 0 |
|||
FOR I = 0 TO (finish - start) |
|||
BeadSort_Sum = BeadSort_Sum + beads(I, BeadSort_J) |
|||
beads(I, BeadSort_J) = 0 |
|||
NEXT |
|||
FOR I = (finish - start) TO (finish - start) - BeadSort_Sum STEP -1 |
|||
beads(I, BeadSort_J) = 1 |
|||
NEXT |
|||
NEXT |
|||
FOR BeadSort_I = 0 TO (finish - start) |
|||
BeadSort_J = 0 |
|||
WHILE BeadSort_J < MAX AND beads(BeadSort_I, BeadSort_J) |
|||
BeadSort_J = BeadSort_J + 1 |
|||
WEND |
|||
CGSortLibArray(finish - BeadSort_I) = BeadSort_J |
|||
NEXT |
|||
END IF |
|||
END SUB |
|||
</syntaxhighlight> |
|||
=={{header|Racket}}== |
|||
{{trans|Haskell}} |
|||
<syntaxhighlight lang="racket"> |
|||
#lang racket |
|||
(require rackunit) |
|||
(define (columns lst) |
|||
/*get some grassHopper numbers. */ |
|||
(match (filter (λ (l) (not (empty? l))) lst) |
|||
grasshopper=, |
|||
['() '()] |
|||
1 4 10 12 22 26 30 46 54 62 66 78 94 110 126 134 138 158 162 186 190 222 254 270 |
|||
[l (cons (map car l) (columns (map cdr l)))])) |
|||
(define (bead-sort lst) |
|||
(map length (columns (columns (map (λ (n) (make-list n 1)) lst))))) |
|||
;; unit test |
|||
(check-equal? |
|||
(bead-sort '(5 3 1 7 4 1 1)) |
|||
'(7 5 4 3 1 1 1)) |
|||
</syntaxhighlight> |
|||
=={{header|Raku}}== |
|||
/*GreeenGrocer numbers are also called hexagonal pyramidal */ |
|||
(formerly Perl 6) |
|||
/* numbers. */ |
|||
{{Works with|rakudo|2016-05}} |
|||
greengrocer=, |
|||
{{trans|Haskell}} |
|||
0 4 16 40 80 140 224 336 480 660 880 1144 1456 1820 2240 2720 3264 3876 4560 |
|||
<syntaxhighlight lang="raku" line># routine cribbed from List::Utils; |
|||
sub transpose(@list is copy) { |
|||
gather { |
|||
while @list { |
|||
my @heads; |
|||
if @list[0] !~~ Positional { @heads = @list.shift; } |
|||
else { @heads = @list.map({$_.shift unless $_ ~~ []}); } |
|||
@list = @list.map({$_ unless $_ ~~ []}); |
|||
take [@heads]; |
|||
} |
|||
} |
|||
} |
|||
sub beadsort(@l) { |
|||
(transpose(transpose(map {[1 xx $_]}, @l))).map(*.elems); |
|||
} |
|||
my @list = 2,1,3,5; |
|||
/*get some Bernoulli numerator numbers. */ |
|||
say beadsort(@list).perl;</syntaxhighlight> |
|||
bernN='1 -1 1 0 -1 0 1 0 -1 0 5 0 -691 0 7 0 -3617 0 43867 0 -174611 0 854513' |
|||
{{out}} |
|||
<pre>(5, 3, 2, 1)</pre> |
|||
Here we simulate the dropping beads by using the <tt>push</tt> method. |
|||
<syntaxhighlight lang="raku" line>sub beadsort(*@list) { |
|||
my @rods; |
|||
for words ^«@list -> $x { @rods[$x].push(1) } |
|||
gather for ^@rods[0] -> $y { |
|||
take [+] @rods.map: { .[$y] // last } |
|||
} |
|||
} |
|||
say beadsort 2,1,3,5;</syntaxhighlight> |
|||
/*Psi is also called the Reduced Totient function, and */ |
|||
The <tt>^</tt> is the "upto" operator that gives a range of 0 up to (but not including) its endpoint. We use it as a hyperoperator (<tt>^«</tt>) to generate all the ranges of rod numbers we should drop a bead on, with the result that <tt>$x</tt> tells us which rod to drop each bead on. Then we use <tt>^</tt> again on the first rod to see how deep the beads are stacked, since they are guaranteed to be the deepest there. The <tt>[+]</tt> adds up all the beads that are found at level <tt>$y</tt>. The <tt>last</tt> short circuits the map so we don't have to look for all the missing beads at a given level, since the missing beads are all guaranteed to come after the existing beads at that level (because we always dropped left to right starting at rod 0). |
|||
/* is also called Carmichale lambda, or LAMBDA function.*/ |
|||
psi=, |
|||
1 1 2 2 4 2 6 2 6 4 10 2 12 6 4 4 16 6 18 4 6 10 22 2 20 12 18 6 28 4 30 8 10 16 |
|||
=={{header|REXX}}== |
|||
The REXX language has the advantage of supporting sparse arrays, so implementing a bead sort is trivial, the |
|||
<br>major drawback is ''if'' the spread (difference between the lowest and highest values) is quite large (if it's |
|||
<br>greater than a few million), it'll slow up the display (but not the sorting). |
|||
Zero, negative, and duplicate integers (values) can be handled. |
|||
<syntaxhighlight lang="rexx">/*REXX program sorts a list (4 groups) of integers using the bead sort algorithm. */ |
|||
/* original source by Gerard Schildberger */ |
|||
/* 20230605 Walter Pachl reformatted and refurbished */ |
|||
/* define two dozen grasshopper numbers. */ |
|||
/* source ?? */ |
|||
gHopper=1 4 10 12 22 26 30 46 54 62 66 78 94 110 126 134 138 158 162 186 190 222 254, |
|||
270 |
|||
/* these are also called hexagonal pyramidal #s. */ |
|||
/* see https://oeis.org/A002412 */ |
|||
greenGrocer=0 4 16 40 80 140 224 336 480 660 880 1144 1456 1820 2240 2720 3264 3876, |
|||
4560 |
|||
/* define twenty-three Bernoulli numerator numbers*/ |
|||
/* source ?? quotes needed because of negative #s.*/ |
|||
bernN='1 -1 1 0 -1 0 1 0 -1 0 5 0 -691 0 7 0 -3617 0 43867 0 -174611 0' |
|||
/* also called the Reduced Totient function, */ |
|||
/* and is also called Carmichael lambda, */ |
|||
/* or the LAMBDA function */ |
|||
/* see https://en.wikipedia.org/wiki/Carmichael_function */ |
|||
psi=1 1 2 2 4 2 6 2 6 4 10 2 12 6 4 4 16 6 18 4 6 10 22 2 20 12 18 6 28 4 30 8 10 16 |
|||
list=gHopper greenGrocer bernN psi /*combine the four lists into one list.*/ |
|||
Call show 'before sort',list /*display the list before sorting. */ |
|||
Say copies('¦', 75) /*show long separator line before sort.*/ |
|||
Call show ' after sort',beadSort(list) /*display the list after sorting. */ |
|||
Exit /*stick a fork in it, we're all done. */ |
|||
/*----------------------------------------------------------------------------------*/ |
|||
beadSort: Procedure |
|||
Parse Arg list 1 low . 1 high . /* List to be sorted and first value */ |
|||
occurences.=0 /* count stem occurences */ |
|||
Do Until list=='' /* loop through the list */ |
|||
Parse Var list bead list /* take an element */ |
|||
bead= bead / 1 /* normalize the value */ |
|||
occurences.bead=occurences.bead + 1 /* bump occurences */ |
|||
low= min(low, bead) /* track lowest */ |
|||
high=max(high,bead) /* and highest number */ |
|||
End |
|||
sorted='' /* now, collect the beads */ |
|||
Do v=low To high |
|||
If occurences.v>0 Then |
|||
sorted=sorted copies(v' ', occurences.v) |
|||
End |
|||
Return sorted |
|||
/*----------------------------------------------------------------------------------*/ |
|||
show: |
|||
Parse Arg txt,slist |
|||
n=words(slist) |
|||
w=length(n) |
|||
Do k=1 For n |
|||
Say right('element',30) right(k,w) txt':' right(word(slist,k),9) |
|||
End |
|||
Return</syntaxhighlight> |
|||
{{out|output|text= when using the default input:}} |
|||
(Shown at three-quarter size.) |
|||
<pre style="font-size:75%;height:90ex"> |
|||
element 1 before sort: 1 |
|||
element 2 before sort: 4 |
|||
element 3 before sort: 10 |
|||
element 4 before sort: 12 |
|||
element 5 before sort: 22 |
|||
element 6 before sort: 26 |
|||
element 7 before sort: 30 |
|||
element 8 before sort: 46 |
|||
element 9 before sort: 54 |
|||
element 10 before sort: 62 |
|||
element 11 before sort: 66 |
|||
element 12 before sort: 78 |
|||
element 13 before sort: 94 |
|||
element 14 before sort: 110 |
|||
element 15 before sort: 126 |
|||
element 16 before sort: 134 |
|||
element 17 before sort: 138 |
|||
element 18 before sort: 158 |
|||
element 19 before sort: 162 |
|||
element 20 before sort: 186 |
|||
element 21 before sort: 190 |
|||
element 22 before sort: 222 |
|||
element 23 before sort: 254 |
|||
element 24 before sort: 270 |
|||
element 25 before sort: 0 |
|||
element 26 before sort: 4 |
|||
element 27 before sort: 16 |
|||
element 28 before sort: 40 |
|||
element 29 before sort: 80 |
|||
element 30 before sort: 140 |
|||
element 31 before sort: 224 |
|||
element 32 before sort: 336 |
|||
element 33 before sort: 480 |
|||
element 34 before sort: 660 |
|||
element 35 before sort: 880 |
|||
element 36 before sort: 1144 |
|||
element 37 before sort: 1456 |
|||
element 38 before sort: 1820 |
|||
element 39 before sort: 2240 |
|||
element 40 before sort: 2720 |
|||
element 41 before sort: 3264 |
|||
element 42 before sort: 3876 |
|||
element 43 before sort: 4560 |
|||
element 44 before sort: 1 |
|||
element 45 before sort: -1 |
|||
element 46 before sort: 1 |
|||
element 47 before sort: 0 |
|||
element 48 before sort: -1 |
|||
element 49 before sort: 0 |
|||
element 50 before sort: 1 |
|||
element 51 before sort: 0 |
|||
element 52 before sort: -1 |
|||
element 53 before sort: 0 |
|||
element 54 before sort: 5 |
|||
element 55 before sort: 0 |
|||
element 56 before sort: -691 |
|||
element 57 before sort: 0 |
|||
element 58 before sort: 7 |
|||
element 59 before sort: 0 |
|||
element 60 before sort: -3617 |
|||
element 61 before sort: 0 |
|||
element 62 before sort: 43867 |
|||
element 63 before sort: 0 |
|||
element 64 before sort: -174611 |
|||
element 65 before sort: 0 |
|||
element 66 before sort: 1 |
|||
element 67 before sort: 1 |
|||
element 68 before sort: 2 |
|||
element 69 before sort: 2 |
|||
element 70 before sort: 4 |
|||
element 71 before sort: 2 |
|||
element 72 before sort: 6 |
|||
element 73 before sort: 2 |
|||
element 74 before sort: 6 |
|||
element 75 before sort: 4 |
|||
element 76 before sort: 10 |
|||
element 77 before sort: 2 |
|||
element 78 before sort: 12 |
|||
element 79 before sort: 6 |
|||
element 80 before sort: 4 |
|||
element 81 before sort: 4 |
|||
element 82 before sort: 16 |
|||
element 83 before sort: 6 |
|||
element 84 before sort: 18 |
|||
element 85 before sort: 4 |
|||
element 86 before sort: 6 |
|||
element 87 before sort: 10 |
|||
element 88 before sort: 22 |
|||
element 89 before sort: 2 |
|||
element 90 before sort: 20 |
|||
element 91 before sort: 12 |
|||
element 92 before sort: 18 |
|||
element 93 before sort: 6 |
|||
element 94 before sort: 28 |
|||
element 95 before sort: 4 |
|||
element 96 before sort: 30 |
|||
element 97 before sort: 8 |
|||
element 98 before sort: 10 |
|||
element 99 before sort: 16 |
|||
░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ |
|||
element 1 after sort: -174611 |
|||
element 2 after sort: -3617 |
|||
element 3 after sort: -691 |
|||
element 4 after sort: -1 |
|||
element 5 after sort: -1 |
|||
element 6 after sort: -1 |
|||
element 7 after sort: 0 |
|||
element 8 after sort: 0 |
|||
element 9 after sort: 0 |
|||
element 10 after sort: 0 |
|||
element 11 after sort: 0 |
|||
element 12 after sort: 0 |
|||
element 13 after sort: 0 |
|||
element 14 after sort: 0 |
|||
element 15 after sort: 0 |
|||
element 16 after sort: 0 |
|||
element 17 after sort: 0 |
|||
element 18 after sort: 1 |
|||
element 19 after sort: 1 |
|||
element 20 after sort: 1 |
|||
element 21 after sort: 1 |
|||
element 22 after sort: 1 |
|||
element 23 after sort: 1 |
|||
element 24 after sort: 2 |
|||
element 25 after sort: 2 |
|||
element 26 after sort: 2 |
|||
element 27 after sort: 2 |
|||
element 28 after sort: 2 |
|||
element 29 after sort: 2 |
|||
element 30 after sort: 4 |
|||
element 31 after sort: 4 |
|||
element 32 after sort: 4 |
|||
element 33 after sort: 4 |
|||
element 34 after sort: 4 |
|||
element 35 after sort: 4 |
|||
element 36 after sort: 4 |
|||
element 37 after sort: 4 |
|||
element 38 after sort: 5 |
|||
element 39 after sort: 6 |
|||
element 40 after sort: 6 |
|||
element 41 after sort: 6 |
|||
element 42 after sort: 6 |
|||
element 43 after sort: 6 |
|||
element 44 after sort: 6 |
|||
element 45 after sort: 7 |
|||
element 46 after sort: 8 |
|||
element 47 after sort: 10 |
|||
element 48 after sort: 10 |
|||
element 49 after sort: 10 |
|||
element 50 after sort: 10 |
|||
element 51 after sort: 12 |
|||
element 52 after sort: 12 |
|||
element 53 after sort: 12 |
|||
element 54 after sort: 16 |
|||
element 55 after sort: 16 |
|||
element 56 after sort: 16 |
|||
element 57 after sort: 18 |
|||
element 58 after sort: 18 |
|||
element 59 after sort: 20 |
|||
element 60 after sort: 22 |
|||
element 61 after sort: 22 |
|||
element 62 after sort: 26 |
|||
element 63 after sort: 28 |
|||
element 64 after sort: 30 |
|||
element 65 after sort: 30 |
|||
element 66 after sort: 40 |
|||
element 67 after sort: 46 |
|||
element 68 after sort: 54 |
|||
element 69 after sort: 62 |
|||
element 70 after sort: 66 |
|||
element 71 after sort: 78 |
|||
element 72 after sort: 80 |
|||
element 73 after sort: 94 |
|||
element 74 after sort: 110 |
|||
element 75 after sort: 126 |
|||
element 76 after sort: 134 |
|||
element 77 after sort: 138 |
|||
element 78 after sort: 140 |
|||
element 79 after sort: 158 |
|||
element 80 after sort: 162 |
|||
element 81 after sort: 186 |
|||
element 82 after sort: 190 |
|||
element 83 after sort: 222 |
|||
element 84 after sort: 224 |
|||
element 85 after sort: 254 |
|||
element 86 after sort: 270 |
|||
element 87 after sort: 336 |
|||
element 88 after sort: 480 |
|||
element 89 after sort: 660 |
|||
element 90 after sort: 880 |
|||
element 91 after sort: 1144 |
|||
element 92 after sort: 1456 |
|||
element 93 after sort: 1820 |
|||
element 94 after sort: 2240 |
|||
element 95 after sort: 2720 |
|||
element 96 after sort: 3264 |
|||
element 97 after sort: 3876 |
|||
element 98 after sort: 4560 |
|||
element 99 after sort: 43867 |
|||
</pre> |
|||
=={{header|Ruby}}== |
|||
list=grasshopper greengrocer bernN psi /*combine the four lists into one*/ |
|||
{{trans|Haskell}} |
|||
<syntaxhighlight lang="ruby">class Array |
|||
def beadsort |
|||
map {|e| [1] * e}.columns.columns.map(&:length) |
|||
end |
|||
def columns |
|||
y = length |
|||
x = map(&:length).max |
|||
Array.new(x) do |row| |
|||
Array.new(y) { |column| self[column][row] }.compact # Remove nils. |
|||
end |
|||
end |
|||
end |
|||
# Demonstration code: |
|||
p [5,3,1,7,4,1,1].beadsort</syntaxhighlight> |
|||
{{out}} |
|||
call showL 'before sort',list /*show list before sorting. */ |
|||
<pre>[7, 5, 4, 3, 1, 1, 1]</pre> |
|||
$=beadSort(list) /*invoke the bead sort. */ |
|||
call showL ' after sort',$ /*show after array elements*/ |
|||
exit |
|||
=={{header|Seed7}}== |
|||
<syntaxhighlight lang="seed7">$ include "seed7_05.s7i"; |
|||
const proc: beadSort (inout array integer: a) is func |
|||
/*─────────────────────────────────────SHOW@ subroutine────────────*/ |
|||
local |
|||
beadSort: procedure expose @.; parse arg z |
|||
var integer: max is 0; |
|||
$='' /*this'll be the sorted list*/ |
|||
var integer: sum is 0; |
|||
low=999999999; high=-low /*define the low and high #s*/ |
|||
var array bitset: beads is 0 times {}; |
|||
@.=0 /*define all beads to zero. */ |
|||
var integer: i is 0; |
|||
var integer: j is 0; |
|||
begin |
|||
beads := length(a) times {}; |
|||
for i range 1 to length(a) do |
|||
if a[i] > max then |
|||
max := a[i]; |
|||
end if; |
|||
beads[i] := {1 .. a[i]}; |
|||
end for; |
|||
for j range 1 to max do |
|||
sum := 0; |
|||
for i range 1 to length(a) do |
|||
sum +:= ord(j in beads[i]); |
|||
end for; |
|||
for i range length(a) downto length(a) - sum + 1 do |
|||
a[i] := j; |
|||
end for; |
|||
end for; |
|||
end func; |
|||
const proc: main is func |
|||
local |
|||
var array integer: a is [] (5, 3, 1, 7, 4, 1, 1, 20); |
|||
var integer: n is 0; |
|||
begin |
|||
beadSort(a); |
|||
for n range a do |
|||
write(n <& " "); |
|||
end for; |
|||
writeln; |
|||
end func;</syntaxhighlight> |
|||
{{out}} |
|||
do j=1 until z=='' /*pick the meat off the bone*/ |
|||
<pre> |
|||
parse var z x z |
|||
1 1 1 3 4 5 7 20 |
|||
if \datatype(x,'Whole') then do |
|||
</pre> |
|||
say; say '*** error! ***'; say |
|||
say 'element' j "in list isn't numeric:" x |
|||
say |
|||
exit 13 |
|||
end |
|||
=={{header|Sidef}}== |
|||
x=x/1 /*normalize number, it could*/ |
|||
{{trans|Perl}} |
|||
/*be: +4 007 5. 2e3 etc.*/ |
|||
<syntaxhighlight lang="ruby">func beadsort(arr) { |
|||
@.x=@.x+1 /*indicate this bead has a #*/ |
|||
low=min(low,x) /*keep track of the lowest #*/ |
|||
high=max(high,x) /* " " " " highest#*/ |
|||
end /*j*/ |
|||
var rows = [] |
|||
/*now, collect the beads and*/ |
|||
var columns = [] |
|||
do m=low to high /*let them fall (to zero). */ |
|||
if @.m==0 then iterate /*No bead here? Keep looking*/ |
|||
do n=1 for @.m /*let the beads fall to 0. */ |
|||
$=$ m /*add it to the sorted list.*/ |
|||
end |
|||
end |
|||
for datum in arr { |
|||
return $ |
|||
for column in ^datum { |
|||
++(columns[column] := 0) |
|||
++(rows[columns[column] - 1] := 0) |
|||
} |
|||
} |
|||
rows.reverse |
|||
} |
|||
say beadsort([5,3,1,7,4,1,1])</syntaxhighlight> |
|||
/*─────────────────────────────────────SHOW@ subroutine────────────*/ |
|||
showL: widthH=length(words(arg(2))) /*maximum width of the index*/ |
|||
{{out}} |
|||
do j=1 for words(arg(2)) |
|||
<pre> |
|||
say 'element' right(j,widthH) arg(1)":" right(word(arg(2),j),10) |
|||
[1, 1, 1, 3, 4, 5, 7] |
|||
end |
|||
say copies('─',80) /*show a seperator line. */ |
|||
return |
|||
</lang> |
|||
Output: |
|||
<pre style="height:30ex;overflow:scroll"> |
|||
element 1 before sort: 1 |
|||
element 2 before sort: 4 |
|||
element 3 before sort: 10 |
|||
element 4 before sort: 12 |
|||
element 5 before sort: 22 |
|||
element 6 before sort: 26 |
|||
element 7 before sort: 30 |
|||
element 8 before sort: 46 |
|||
element 9 before sort: 54 |
|||
element 10 before sort: 62 |
|||
element 11 before sort: 66 |
|||
element 12 before sort: 78 |
|||
element 13 before sort: 94 |
|||
element 14 before sort: 110 |
|||
element 15 before sort: 126 |
|||
element 16 before sort: 134 |
|||
element 17 before sort: 138 |
|||
element 18 before sort: 158 |
|||
element 19 before sort: 162 |
|||
element 20 before sort: 186 |
|||
element 21 before sort: 190 |
|||
element 22 before sort: 222 |
|||
element 23 before sort: 254 |
|||
element 24 before sort: 270 |
|||
element 25 before sort: 0 |
|||
element 26 before sort: 4 |
|||
element 27 before sort: 16 |
|||
element 28 before sort: 40 |
|||
element 29 before sort: 80 |
|||
element 30 before sort: 140 |
|||
element 31 before sort: 224 |
|||
element 32 before sort: 336 |
|||
element 33 before sort: 480 |
|||
element 34 before sort: 660 |
|||
element 35 before sort: 880 |
|||
element 36 before sort: 1144 |
|||
element 37 before sort: 1456 |
|||
element 38 before sort: 1820 |
|||
element 39 before sort: 2240 |
|||
element 40 before sort: 2720 |
|||
element 41 before sort: 3264 |
|||
element 42 before sort: 3876 |
|||
element 43 before sort: 4560 |
|||
element 44 before sort: 1 |
|||
element 45 before sort: -1 |
|||
element 46 before sort: 1 |
|||
element 47 before sort: 0 |
|||
element 48 before sort: -1 |
|||
element 49 before sort: 0 |
|||
element 50 before sort: 1 |
|||
element 51 before sort: 0 |
|||
element 52 before sort: -1 |
|||
element 53 before sort: 0 |
|||
element 54 before sort: 5 |
|||
element 55 before sort: 0 |
|||
element 56 before sort: -691 |
|||
element 57 before sort: 0 |
|||
element 58 before sort: 7 |
|||
element 59 before sort: 0 |
|||
element 60 before sort: -3617 |
|||
element 61 before sort: 0 |
|||
element 62 before sort: 43867 |
|||
element 63 before sort: 0 |
|||
element 64 before sort: -174611 |
|||
element 65 before sort: 0 |
|||
element 66 before sort: 854513 |
|||
element 67 before sort: 1 |
|||
element 68 before sort: 1 |
|||
element 69 before sort: 2 |
|||
element 70 before sort: 2 |
|||
element 71 before sort: 4 |
|||
element 72 before sort: 2 |
|||
element 73 before sort: 6 |
|||
element 74 before sort: 2 |
|||
element 75 before sort: 6 |
|||
element 76 before sort: 4 |
|||
element 77 before sort: 10 |
|||
element 78 before sort: 2 |
|||
element 79 before sort: 12 |
|||
element 80 before sort: 6 |
|||
element 81 before sort: 4 |
|||
element 82 before sort: 4 |
|||
element 83 before sort: 16 |
|||
element 84 before sort: 6 |
|||
element 85 before sort: 18 |
|||
element 86 before sort: 4 |
|||
element 87 before sort: 6 |
|||
element 88 before sort: 10 |
|||
element 89 before sort: 22 |
|||
element 90 before sort: 2 |
|||
element 91 before sort: 20 |
|||
element 92 before sort: 12 |
|||
element 93 before sort: 18 |
|||
element 94 before sort: 6 |
|||
element 95 before sort: 28 |
|||
element 96 before sort: 4 |
|||
element 97 before sort: 30 |
|||
element 98 before sort: 8 |
|||
element 99 before sort: 10 |
|||
element 100 before sort: 16 |
|||
──────────────────────────────────────────────────────────────────────────────── |
|||
element 1 after sort: -174611 |
|||
element 2 after sort: -3617 |
|||
element 3 after sort: -691 |
|||
element 4 after sort: -1 |
|||
element 5 after sort: -1 |
|||
element 6 after sort: -1 |
|||
element 7 after sort: 0 |
|||
element 8 after sort: 0 |
|||
element 9 after sort: 0 |
|||
element 10 after sort: 0 |
|||
element 11 after sort: 0 |
|||
element 12 after sort: 0 |
|||
element 13 after sort: 0 |
|||
element 14 after sort: 0 |
|||
element 15 after sort: 0 |
|||
element 16 after sort: 0 |
|||
element 17 after sort: 0 |
|||
element 18 after sort: 1 |
|||
element 19 after sort: 1 |
|||
element 20 after sort: 1 |
|||
element 21 after sort: 1 |
|||
element 22 after sort: 1 |
|||
element 23 after sort: 1 |
|||
element 24 after sort: 2 |
|||
element 25 after sort: 2 |
|||
element 26 after sort: 2 |
|||
element 27 after sort: 2 |
|||
element 28 after sort: 2 |
|||
element 29 after sort: 2 |
|||
element 30 after sort: 4 |
|||
element 31 after sort: 4 |
|||
element 32 after sort: 4 |
|||
element 33 after sort: 4 |
|||
element 34 after sort: 4 |
|||
element 35 after sort: 4 |
|||
element 36 after sort: 4 |
|||
element 37 after sort: 4 |
|||
element 38 after sort: 5 |
|||
element 39 after sort: 6 |
|||
element 40 after sort: 6 |
|||
element 41 after sort: 6 |
|||
element 42 after sort: 6 |
|||
element 43 after sort: 6 |
|||
element 44 after sort: 6 |
|||
element 45 after sort: 7 |
|||
element 46 after sort: 8 |
|||
element 47 after sort: 10 |
|||
element 48 after sort: 10 |
|||
element 49 after sort: 10 |
|||
element 50 after sort: 10 |
|||
element 51 after sort: 12 |
|||
element 52 after sort: 12 |
|||
element 53 after sort: 12 |
|||
element 54 after sort: 16 |
|||
element 55 after sort: 16 |
|||
element 56 after sort: 16 |
|||
element 57 after sort: 18 |
|||
element 58 after sort: 18 |
|||
element 59 after sort: 20 |
|||
element 60 after sort: 22 |
|||
element 61 after sort: 22 |
|||
element 62 after sort: 26 |
|||
element 63 after sort: 28 |
|||
element 64 after sort: 30 |
|||
element 65 after sort: 30 |
|||
element 66 after sort: 40 |
|||
element 67 after sort: 46 |
|||
element 68 after sort: 54 |
|||
element 69 after sort: 62 |
|||
element 70 after sort: 66 |
|||
element 71 after sort: 78 |
|||
element 72 after sort: 80 |
|||
element 73 after sort: 94 |
|||
element 74 after sort: 110 |
|||
element 75 after sort: 126 |
|||
element 76 after sort: 134 |
|||
element 77 after sort: 138 |
|||
element 78 after sort: 140 |
|||
element 79 after sort: 158 |
|||
element 80 after sort: 162 |
|||
element 81 after sort: 186 |
|||
element 82 after sort: 190 |
|||
element 83 after sort: 222 |
|||
element 84 after sort: 224 |
|||
element 85 after sort: 254 |
|||
element 86 after sort: 270 |
|||
element 87 after sort: 336 |
|||
element 88 after sort: 480 |
|||
element 89 after sort: 660 |
|||
element 90 after sort: 880 |
|||
element 91 after sort: 1144 |
|||
element 92 after sort: 1456 |
|||
element 93 after sort: 1820 |
|||
element 94 after sort: 2240 |
|||
element 95 after sort: 2720 |
|||
element 96 after sort: 3264 |
|||
element 97 after sort: 3876 |
|||
element 98 after sort: 4560 |
|||
element 99 after sort: 43867 |
|||
element 100 after sort: 854513 |
|||
──────────────────────────────────────────────────────────────────────────────── |
|||
</pre> |
</pre> |
||
=={{header| |
=={{header|Standard ML}}== |
||
{{trans|Haskell}} |
{{trans|Haskell}} |
||
<syntaxhighlight lang="sml">fun columns l = |
|||
<lang ruby>class Array |
|||
case List.filter (not o null) l of |
|||
def beadsort |
|||
[] => [] |
|||
self.map {|e| [1] * e}.columns.columns.map {|e| e.length} |
|||
| l => map hd l :: columns (map tl l) |
|||
end |
|||
fun replicate (n, x) = List.tabulate (n, fn _ => x) |
|||
def columns |
|||
y = self.length |
|||
x = self.map {|l| l.length}.max |
|||
fun bead_sort l = |
|||
Array.new(x) do |row| |
|||
map length (columns (columns (map (fn e => replicate (e, 1)) l)))</syntaxhighlight> |
|||
Array.new(y) { |column| |
|||
usage |
|||
self[column][row] |
|||
<pre> |
|||
}.compact # Remove nulls. |
|||
- bead_sort [5,3,1,7,4,1,1]; |
|||
end |
|||
val it = [7,5,4,3,1,1,1] : int list |
|||
end |
|||
</pre> |
|||
end |
|||
# Demonstration code: |
|||
[5,3,1,7,4,1,1].beadsort</lang> |
|||
Output: |
|||
<pre>=> [7, 5, 4, 3, 1, 1, 1]</pre> |
|||
=={{header|Tcl}}== |
=={{header|Tcl}}== |
||
< |
<syntaxhighlight lang="tcl">package require Tcl 8.5 |
||
proc beadsort numList { |
proc beadsort numList { |
||
Line 1,180: | Line 3,454: | ||
# Demonstration code |
# Demonstration code |
||
puts [beadsort {5 3 1 7 4 1 1}]</ |
puts [beadsort {5 3 1 7 4 1 1}]</syntaxhighlight> |
||
{{out}} |
|||
Output: |
|||
<pre>7 5 4 3 1 1 1</pre> |
<pre>7 5 4 3 1 1 1</pre> |
||
=={{header|VBA}}== |
|||
{{trans|Phix}}<syntaxhighlight lang="vb">Option Base 1 |
|||
Private Function sq_add(arr As Variant, x As Double) As Variant |
|||
Dim res() As Variant |
|||
ReDim res(UBound(arr)) |
|||
For i = 1 To UBound(arr) |
|||
res(i) = arr(i) + x |
|||
Next i |
|||
sq_add = res |
|||
End Function |
|||
Private Function beadsort(ByVal a As Variant) As Variant |
|||
Dim poles() As Variant |
|||
ReDim poles(WorksheetFunction.Max(a)) |
|||
For i = 1 To UBound(a) |
|||
For j = 1 To a(i) |
|||
poles(j) = poles(j) + 1 |
|||
Next j |
|||
Next i |
|||
For j = 1 To UBound(a) |
|||
a(j) = 0 |
|||
Next j |
|||
For i = 1 To UBound(poles) |
|||
For j = 1 To poles(i) |
|||
a(j) = a(j) + 1 |
|||
Next j |
|||
Next i |
|||
beadsort = a |
|||
End Function |
|||
Public Sub main() |
|||
Debug.Print Join(beadsort([{5, 3, 1, 7, 4, 1, 1, 20}]), ", ") |
|||
End Sub</syntaxhighlight>{{out}} |
|||
<pre>20, 7, 5, 4, 3, 1, 1, 1</pre> |
|||
=={{header|Wren}}== |
|||
A translation of the Python code in the Wikipedia article. Only works properly for lists of non-negative integers. |
|||
<syntaxhighlight lang="wren">var beadSort = Fn.new { |a| |
|||
var res = [] |
|||
var max = a.reduce { |acc, i| (i > acc) ? i : acc } |
|||
var trans = [0] * max |
|||
for (i in a) { |
|||
for (n in 0...i) trans[n] = trans[n] + 1 |
|||
} |
|||
for (i in a) { |
|||
res.add(trans.count { |n| n > 0 }) |
|||
for (n in 0...trans.count) trans[n] = trans[n] - 1 |
|||
} |
|||
return res[-1..0] // return in ascending order |
|||
} |
|||
var array = [ [4, 65, 2, 31, 0, 99, 2, 83, 782, 1], [7, 5, 2, 6, 1, 4, 2, 6, 3] ] |
|||
for (a in array) { |
|||
System.print("Before: %(a)") |
|||
a = beadSort.call(a) |
|||
System.print("After : %(a)") |
|||
System.print() |
|||
}</syntaxhighlight> |
|||
{{out}} |
|||
<pre> |
|||
Before: [4, 65, 2, 31, 0, 99, 2, 83, 782, 1] |
|||
After : [0, 1, 2, 2, 4, 31, 65, 83, 99, 782] |
|||
Before: [7, 5, 2, 6, 1, 4, 2, 6, 3] |
|||
After : [1, 2, 2, 3, 4, 5, 6, 6, 7] |
|||
</pre> |
|||
=={{header|XPL0}}== |
|||
<syntaxhighlight lang="xpl0">include c:\cxpl\codes; |
|||
proc BeadSort(Array, Length); \Sort Array into increasing order |
|||
int Array, Length; \Array contents range 0..31; number of items |
|||
int Row, I, J, T, C; |
|||
[Row:= Reserve(Length*4); \each Row has room for 32 beads |
|||
for I:= 0 to Length-1 do \each Row gets Array(I) number of beads |
|||
Row(I):= ~-1<<Array(I); \(beware for 80186..Pentium <<32 doesn't shift) |
|||
for J:= 1 to Length-1 do |
|||
for I:= Length-1 downto J do |
|||
[T:= Row(I-1) & ~Row(I); \up to 31 beads fall in a single pass |
|||
Row(I-1):= Row(I-1) | T; \(|=xor, !=or) |
|||
Row(I):= Row(I) | T; |
|||
]; |
|||
for I:= 0 to Length-1 do \count beads in each Row |
|||
[C:= 0; T:= Row(I); |
|||
while T do |
|||
[if T&1 then C:= C+1; T:= T>>1]; |
|||
Array(I):= C; \count provides sorted order |
|||
]; |
|||
]; |
|||
int A, I; |
|||
[A:= [3, 1, 4, 1, 25, 9, 2, 6, 5, 0]; |
|||
BeadSort(A, 10); |
|||
for I:= 0 to 10-1 do [IntOut(0, A(I)); ChOut(0, ^ )]; |
|||
]</syntaxhighlight> |
|||
{{out}} |
|||
<pre> |
|||
0 1 1 2 3 4 5 6 9 25 |
|||
</pre> |
|||
=={{header|zkl}}== |
|||
{{trans|D}} |
|||
<syntaxhighlight lang="zkl">fcn columns(m){ // m is list of lists of zeros/beads, # beads is n, eg (0,0,0)==3 |
|||
m |
|||
.apply("len") // (0,0,0)-->3 |
|||
.reduce("max") // largest bead stack |
|||
.walker() // [0..max] |
|||
.apply('wrap(i){ m.filter('wrap(s){ s.len() > i }).len().pump(List,0) }); |
|||
} |
|||
fcn beadSort(data){ |
|||
data.apply("pump",List,0):columns(_):columns(_).apply("len"); |
|||
}</syntaxhighlight> |
|||
<syntaxhighlight lang="zkl">T(5,3,1,7,4,1,1):beadSort(_).println(); |
|||
T(4,3,3,2,1):beadSort(_).println();</syntaxhighlight> |
|||
{{out}} |
|||
<pre> |
|||
L(7,5,4,3,1,1,1) |
|||
L(4,3,3,2,1) |
|||
</pre> |
|||
Latest revision as of 11:18, 8 February 2024
![Task](http://static.miraheze.org/rosettacodewiki/thumb/b/ba/Rcode-button-task-crushed.png/64px-Rcode-button-task-crushed.png)
You are encouraged to solve this task according to the task description, using any language you may know.
Sorting Algorithm
This is a sorting algorithm. It may be applied to a set of data in order to sort it.
For comparing various sorts, see compare sorts.
For other sorting algorithms, see sorting algorithms, or:
Heap sort | Merge sort | Patience sort | Quick sort
O(n log2n) sorts
Shell Sort
O(n2) sorts
Bubble sort |
Cocktail sort |
Cocktail sort with shifting bounds |
Comb sort |
Cycle sort |
Gnome sort |
Insertion sort |
Selection sort |
Strand sort
other sorts
Bead sort |
Bogo sort |
Common sorted list |
Composite structures sort |
Custom comparator sort |
Counting sort |
Disjoint sublist sort |
External sort |
Jort sort |
Lexicographical sort |
Natural sorting |
Order by pair comparisons |
Order disjoint list items |
Order two numerical lists |
Object identifier (OID) sort |
Pancake sort |
Quickselect |
Permutation sort |
Radix sort |
Ranking methods |
Remove duplicate elements |
Sleep sort |
Stooge sort |
[Sort letters of a string] |
Three variable sort |
Topological sort |
Tree sort
- Task
Sort an array of positive integers using the Bead Sort Algorithm.
A bead sort is also known as a gravity sort.
Algorithm has O(S), where S is the sum of the integers in the input set: Each bead is moved individually.
This is the case when bead sort is implemented without a mechanism to assist in finding empty spaces below the beads, such as in software implementations.
11l
F bead_sort(&a)
V maxv = max(a)
V beads = [0] * (maxv * a.len)
L(i) 0 .< a.len
L(j) 0 .< a[i]
beads[i * maxv + j] = 1
L(j) 0 .< maxv
V sum = 0
L(i) 0 .< a.len
sum += beads[i * maxv + j]
beads[i * maxv + j] = 0
L(i) a.len - sum .< a.len
beads[i * maxv + j] = 1
L(i) 0 .< a.len
V j = 0
L j < maxv & beads[i * maxv + j] > 0
j++
a[i] = j
V a = [5, 3, 1, 7, 4, 1, 1, 20]
bead_sort(&a)
print(a)
- Output:
[1, 1, 1, 3, 4, 5, 7, 20]
360 Assembly
For maximum compatibility, this program uses only the basic instruction set (S/360) and two ASSIST macros (XDECO,XPRNT) to keep it as short as possible.
* Bead Sort 11/05/2016
BEADSORT CSECT
USING BEADSORT,R13 base register
SAVEAR B STM-SAVEAR(R15) skip savearea
DC 17F'0' savearea
STM STM R14,R12,12(R13) prolog
ST R13,4(R15) "
ST R15,8(R13) "
LR R13,R15 "
LA R6,1 i=1
LOOPI1 CH R6,=AL2(N) do i=1 to hbound(z)
BH ELOOPI1 leave i
LR R1,R6 i
SLA R1,1 <<1
LH R2,Z-2(R1) z(i)
CH R2,LO if z(i)<lo
BNL EIHO then
STH R2,LO lo=z(i)
EIHLO CH R2,HI if z(i)>hi
BNH EIHHI then
STH R2,HI hi=z(i)
EIHHI LA R6,1(R6) iterate i
B LOOPI1 next i
ELOOPI1 LA R9,1 1
SH R9,LO -lo+1
LA R6,1 i=1
LOOPI2 CH R6,=AL2(N) do i=1 to hbound(z)
BH ELOOPI2 leave i
LR R1,R6 i
SLA R1,1 <<1
LH R3,Z-2(R1) z(i)
AR R3,R9 z(i)+o
IC R2,BEADS-1(R3) beads(l)
LA R2,1(R2) beads(l)+1
STC R2,BEADS-1(R3) beads(l)=beads(l)+1
LA R6,1(R6) iterate i
B LOOPI2 next i
ELOOPI2 SR R8,R8 k=0
LH R6,LO i=lo
LOOPI3 CH R6,HI do i=lo to hi
BH ELOOPI3 leave i
LA R7,1 j=1
SR R10,R10 clear r10
LR R1,R6 i
AR R1,R9 i+o
IC R10,BEADS-1(R1) beads(i+o)
LOOPJ3 CR R7,R10 do j=1 to beads(i+o)
BH ELOOPJ3 leave j
LA R8,1(R8) k=k+1
LR R1,R8 k
SLA R1,1 <<1
STH R6,S-2(R1) s(k)=i
LA R7,1(R7) iterate j
B LOOPJ3 next j
ELOOPJ3 AH R6,=H'1' iterate i
B LOOPI3 next i
ELOOPI3 LA R7,1 j=1
LOOPJ4 CH R7,=H'2' do j=1 to 2
BH ELOOPJ4 leave j
CH R7,=H'1' if j<>1
BE ONE then
MVC PG(7),=C'sorted:' zap
ONE LA R10,PG+7 pgi=@pg+7
LA R6,1 i=1
LOOPI4 CH R6,=AL2(N) do i=1 to hbound(z)
BH ELOOPI4 leave i
CH R7,=H'1' if j=1
BNE TWO then
LR R1,R6 i
SLA R1,1 <<1
LH R11,Z-2(R1) zs=z(i)
B XDECO else
TWO LR R1,R6 i
SLA R1,1 <<1
LH R11,S-2(R1) zs=s(i)
XDECO XDECO R11,XDEC edit zs
MVC 0(6,R10),XDEC+6 output zs
LA R10,6(R10) pgi=pgi+6
LA R6,1(R6) iterate i
B LOOPI4 next i
ELOOPI4 XPRNT PG,80 print buffer
LA R7,1(R7) iterate j
B LOOPJ4 next j
ELOOPJ4 L R13,4(0,R13) epilog
LM R14,R12,12(R13) "
XR R15,R15 "
BR R14 "
LTORG literal table
N EQU (S-Z)/2 number of items
Z DC H'5',H'3',H'1',H'7',H'-1',H'4',H'9',H'-12'
DC H'2001',H'-2010',H'17',H'0'
S DS (N)H s same size as z
LO DC H'32767' 2**31-1
HI DC H'-32768' -2**31
PG DC CL80' raw:' buffer
XDEC DS CL12 temp
BEADS DC 4096X'00' beads
YREGS
END BEADSORT
- Output:
raw: 5 3 1 7 -1 4 9 -12 2001 -2010 17 0 sorted: -2010 -12 -1 0 1 3 4 5 7 9 17 2001
AArch64 Assembly
/* ARM assembly AARCH64 Raspberry PI 3B */
/* program beadSort64.s */
/* En français tri par gravité ou tri par bille (ne pas confondre
avec tri par bulle (bubble sort)) */
/*******************************************/
/* Constantes file */
/*******************************************/
/* for this file see task include a file in language AArch64 assembly*/
.include "../includeConstantesARM64.inc"
/*********************************/
/* Initialized data */
/*********************************/
.data
szMessSortOk: .asciz "Table sorted.\n"
szMessSortNok: .asciz "Table not sorted !!!!!.\n"
sMessResult: .asciz "Value : @ \n"
szCarriageReturn: .asciz "\n"
.align 4
#TableNumber: .quad 1,3,6,2,5,9,10,8,4,7
TableNumber: .quad 10,9,8,7,6,5,4,3,2,1
.equ NBELEMENTS, (. - TableNumber) / 8
//.equ NBELEMENTS, 4 // for others tests
/*********************************/
/* UnInitialized data */
/*********************************/
.bss
sZoneConv: .skip 24
/*********************************/
/* code section */
/*********************************/
.text
.global main
main: // entry of program
1:
ldr x0,qAdrTableNumber // address number table
mov x1,#NBELEMENTS // number of élements
bl beadSort
ldr x0,qAdrTableNumber // address number table
mov x1,#NBELEMENTS // number of élements
bl displayTable
ldr x0,qAdrTableNumber // address number table
mov x1,#NBELEMENTS // number of élements
bl isSorted // control sort
cmp x0,#1 // sorted ?
beq 2f
ldr x0,qAdrszMessSortNok // no !! error sort
bl affichageMess
b 100f
2: // yes
ldr x0,qAdrszMessSortOk
bl affichageMess
100: // standard end of the program
mov x0, #0 // return code
mov x8, #EXIT // request to exit program
svc #0 // perform the system call
qAdrszCarriageReturn: .quad szCarriageReturn
qAdrsMessResult: .quad sMessResult
qAdrTableNumber: .quad TableNumber
qAdrszMessSortOk: .quad szMessSortOk
qAdrszMessSortNok: .quad szMessSortNok
/******************************************************************/
/* control sorted table */
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains the number of elements > 0 */
/* x0 return 0 if not sorted 1 if sorted */
isSorted:
stp x2,lr,[sp,-16]! // save registers
stp x3,x4,[sp,-16]! // save registers
mov x2,#0
ldr x4,[x0,x2,lsl #3] // load A[0]
1:
add x2,x2,#1
cmp x2,x1 // end ?
bge 99f
ldr x3,[x0,x2, lsl #3] // load A[i]
cmp x3,x4 // compare A[i],A[i-1]
blt 98f // smaller -> error -> return
mov x4,x3 // no -> A[i-1] = A[i]
b 1b // and loop
98:
mov x0,#0 // error
b 100f
99:
mov x0,#1 // ok -> return
100:
ldp x2,x3,[sp],16 // restaur 2 registers
ldp x1,lr,[sp],16 // restaur 2 registers
ret // return to address lr x30
/******************************************************************/
/* bead sort */
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains the number of element */
/* Caution registers x2-x12 are not saved */
beadSort:
stp x1,lr,[sp,-16]! // save registers
mov x12,x1 // save elements number
//search max
ldr x10,[x0] // load value A[0] in max
mov x4,#1
1: // loop search max
cmp x4,x12 // end ?
bge 21f // yes
ldr x2,[x0,x4,lsl #3] // load value A[i]
cmp x2,x10 // compare with max
csel x10,x2,x10,gt // if greather
add x4,x4,#1
b 1b // loop
21:
mul x5,x10,x12 // max * elements number
lsl x5,x5,#3 // 8 bytes for each number
sub sp,sp,x5 // allocate on the stack
mov fp,sp // frame pointer = stack address
// marks beads
mov x3,x0 // save table address
mov x0,#0 // start index x
2:
mov x1,#0 // index y
ldr x8,[x3,x0,lsl #3] // load A[x]
mul x6,x0,x10 // compute bead x
3:
add x9,x6,x1 // compute bead y
mov x4,#1 // value to store
str x4,[fp,x9,lsl #3] // store to stack area
add x1,x1,#1
cmp x1,x8
blt 3b
31: // init to zéro the bead end
cmp x1,x10 // max ?
bge 32f
add x9,x6,x1 // compute bead y
mov x4,#0
str x4,[fp,x9,lsl #3]
add x1,x1,#1
b 31b
32:
add x0,x0,#1 // increment x
cmp x0,x12 // end ?
blt 2b
// count beads
mov x1,#0 // y
4:
mov x0,#0 // start index x
mov x8,#0 // sum
5:
mul x6,x0,x10 // compute bead x
add x9,x6,x1 // compute bead y
ldr x4,[fp,x9,lsl #3]
add x8,x8,x4
mov x4,#0
str x4,[fp,x9,lsl #3] // raz bead
add x0,x0,#1
cmp x0,x12
blt 5b
sub x0,x12,x8 // compute end - sum
6:
mul x6,x0,x10 // compute bead x
add x9,x6,x1 // compute bead y
mov x4,#1
str x4,[fp,x9,lsl #3] // store new bead at end
add x0,x0,#1
cmp x0,x12
blt 6b
add x1,x1,#1
cmp x1,x10
blt 4b
// final compute
mov x0,#0 // start index x
7:
mov x1,#0 // start index y
mul x6,x0,x10 // compute bead x
8:
add x9,x6,x1 // compute bead y
ldr x4,[fp,x9,lsl #3] // load bead [x,y]
add x1,x1,#1 // add to x1 before str (index start at zéro)
cmp x4,#1
bne 9f
str x1,[x3,x0, lsl #3] // store A[x]
9:
cmp x1,x10 // compare max
blt 8b
add x0,x0,#1
cmp x0,x12 // end ?
blt 7b
mov x0,#0
add sp,sp,x5 // stack alignement
100:
ldp x1,lr,[sp],16 // restaur 2 registers
ret // return to address lr x30
/******************************************************************/
/* Display table elements */
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains elements number */
displayTable:
stp x1,lr,[sp,-16]! // save registers
stp x2,x3,[sp,-16]! // save registers
mov x2,x0 // table address
mov x4,x1 // elements number
mov x3,#0
1: // loop display table
ldr x0,[x2,x3,lsl #3]
ldr x1,qAdrsZoneConv
bl conversion10 // décimal conversion
ldr x0,qAdrsMessResult
ldr x1,qAdrsZoneConv // insert conversion
bl strInsertAtCharInc
bl affichageMess // display message
add x3,x3,#1
cmp x3,x4 // end ?
blt 1b // no -> loop
ldr x0,qAdrszCarriageReturn
bl affichageMess
100:
ldp x2,x3,[sp],16 // restaur 2 registers
ldp x1,lr,[sp],16 // restaur 2 registers
ret // return to address lr x30
qAdrsZoneConv: .quad sZoneConv
/********************************************************/
/* File Include fonctions */
/********************************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeARM64.inc"
ARM Assembly
/* ARM assembly Raspberry PI */
/* program beadSort.s */
/* En français tri par gravité ou tri par bille (ne pas confondre
avec tri par bulle (bubble sort) */
/* REMARK 1 : this program use routines in a include file
see task Include a file language arm assembly
for the routine affichageMess conversion10
see at end of this program the instruction include */
/* for constantes see task include a file in arm assembly */
/************************************/
/* Constantes */
/************************************/
.include "../constantes.inc"
/*********************************/
/* Initialized data */
/*********************************/
.data
szMessSortOk: .asciz "Table sorted.\n"
szMessSortNok: .asciz "Table not sorted !!!!!.\n"
sMessResult: .asciz "Value : @ \n"
szCarriageReturn: .asciz "\n"
.align 4
TableNumber: .int 1,3,6,2,5,9,10,8,4,7
#TableNumber: .int 10,9,8,7,6,5,4,3,2,1
.equ NBELEMENTS, (. - TableNumber) / 4
@.equ NBELEMENTS, 4 @ for others tests
/*********************************/
/* UnInitialized data */
/*********************************/
.bss
sZoneConv: .skip 24
/*********************************/
/* code section */
/*********************************/
.text
.global main
main: @ entry of program
1:
ldr r0,iAdrTableNumber @ address number table
mov r1,#NBELEMENTS @ number of élements
bl beadSort
ldr r0,iAdrTableNumber @ address number table
mov r1,#NBELEMENTS @ number of élements
bl displayTable
ldr r0,iAdrTableNumber @ address number table
mov r1,#NBELEMENTS @ number of élements
bl isSorted @ control sort
cmp r0,#1 @ sorted ?
beq 2f
ldr r0,iAdrszMessSortNok @ no !! error sort
bl affichageMess
b 100f
2: @ yes
ldr r0,iAdrszMessSortOk
bl affichageMess
100: @ standard end of the program
mov r0, #0 @ return code
mov r7, #EXIT @ request to exit program
svc #0 @ perform the system call
iAdrszCarriageReturn: .int szCarriageReturn
iAdrsMessResult: .int sMessResult
iAdrTableNumber: .int TableNumber
iAdrszMessSortOk: .int szMessSortOk
iAdrszMessSortNok: .int szMessSortNok
/******************************************************************/
/* control sorted table */
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains the number of elements > 0 */
/* r0 return 0 if not sorted 1 if sorted */
isSorted:
push {r2-r4,lr} @ save registers
mov r2,#0
ldr r4,[r0,r2,lsl #2] @ load A[0]
1:
add r2,#1
cmp r2,r1 @ end ?
movge r0,#1 @ yes -> ok -> return
bge 100f
ldr r3,[r0,r2, lsl #2] @ load A[i]
cmp r3,r4 @ compare A[i],A[i-1]
movlt r0,#0 @ smaller ?
blt 100f @ yes -> error -> return
mov r4,r3 @ no -> A[i-1] = A[i]
b 1b @ and loop
100:
pop {r2-r4,lr}
bx lr @ return
/******************************************************************/
/* bead sort */
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains the number of element */
beadSort:
push {r1-r12,lr} @ save registers
mov r12,r1 @ save elements number
@search max
ldr r10,[r0] @ load value A[0] in max
mov r4,#1
1: @ loop search max
cmp r4,r12 @ end ?
bge 21f @ yes
ldr r2,[r0,r4,lsl #2] @ load value A[i]
cmp r2,r10 @ compare with max
movgt r10,r2 @ if greather
add r4,r4,#1
b 1b @ loop
21:
mul r5,r10,r12 @ max * elements number
lsl r5,r5,#2 @ 4 bytes for each number
sub sp,sp,r5 @ allocate on the stack
mov fp,sp @ frame pointer = stack address
@ marks beads
mov r3,r0 @ save table address
mov r0,#0 @ start index x
2:
mov r1,#0 @ index y
ldr r7,[r3,r0,lsl #2] @ load A[x]
mul r6,r0,r10 @ compute bead x
3:
add r9,r6,r1 @ compute bead y
mov r4,#1 @ value to store
str r4,[fp,r9,lsl #2] @ store to stack area
add r1,r1,#1
cmp r1,r7
blt 3b
31: @ init to zéro the bead end
cmp r1,r10 @ max ?
bge 32f
add r9,r6,r1 @ compute bead y
mov r4,#0
str r4,[fp,r9,lsl #2]
add r1,r1,#1
b 31b
32:
add r0,r0,#1 @ increment x
cmp r0,r12 @ end ?
blt 2b
@ count beads
mov r1,#0 @ y
4:
mov r0,#0 @ start index x
mov r8,#0 @ sum
5:
mul r6,r0,r10 @ compute bead x
add r9,r6,r1 @ compute bead y
ldr r4,[fp,r9,lsl #2]
add r8,r8,r4
mov r4,#0
str r4,[fp,r9,lsl #2]
add r0,r0,#1
cmp r0,r12
blt 5b
sub r0,r12,r8
6:
mul r6,r0,r10 @ compute bead x
add r9,r6,r1 @ compute bead y
mov r4,#1
str r4,[fp,r9,lsl #2]
add r0,r0,#1
cmp r0,r12
blt 6b
add r1,r1,#1
cmp r1,r10
blt 4b
@ suite
mov r0,#0 @ start index
7:
mov r1,#0
mul r6,r0,r10 @ compute bead x
8:
add r9,r6,r1 @ compute bead y
ldr r4,[fp,r9,lsl #2]
add r1,r1,#1 @ add to r1 before str (index start at zéro)
cmp r4,#1
streq r1,[r3,r0, lsl #2] @ store A[i]
cmp r1,r10 @ compare max
blt 8b
add r0,r0,#1
cmp r0,r12 @ end ?
blt 7b
mov r0,#0
add sp,sp,r5 @ stack alignement
100:
pop {r1-r12,lr}
bx lr @ return
/******************************************************************/
/* Display table elements */
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains elements number */
displayTable:
push {r0-r4,lr} @ save registers
mov r2,r0 @ table address
mov r4,r1 @ elements number
mov r3,#0
1: @ loop display table
ldr r0,[r2,r3,lsl #2]
ldr r1,iAdrsZoneConv
bl conversion10 @ décimal conversion
ldr r0,iAdrsMessResult
ldr r1,iAdrsZoneConv @ insert conversion
bl strInsertAtCharInc
bl affichageMess @ display message
add r3,r3,#1
cmp r3,r4 @ end ?
blt 1b @ no -> loop
ldr r0,iAdrszCarriageReturn
bl affichageMess
100:
pop {r0-r4,lr}
bx lr
iAdrsZoneConv: .int sZoneConv
/***************************************************/
/* ROUTINES INCLUDE */
/***************************************************/
.include "../affichage.inc"
Arturo
beadSort: function [items][
a: new items
m: neg infinity
s: 0
loop a 'x [
if x > m -> m: x
]
beads: array.of: m * size a 0
loop 0..dec size a 'i [
loop 0..dec a\[i] 'j ->
beads\[j + i * m]: 1
]
loop 0..dec m 'j [
s: 0
loop 0..dec size a 'i [
s: s + beads\[j + i*m]
beads\[j + i*m]: 0
]
loop ((size a)-s)..dec size a 'i ->
beads\[j + i*m]: 1
]
loop 0..dec size a 'i [
j: 0
while [and? [j < m] [beads\[j + i*m] > 0]] -> j: j + 1
a\[i]: j
]
return a
]
print beadSort [3 1 2 8 5 7 9 4 6]
- Output:
1 2 3 4 5 6 7 8 9
AutoHotkey
BeadSort(data){
Pole:=[] , TempObj:=[], Result:=[]
for, i, v in data {
Row := i
loop, % v
MaxPole := MaxPole>A_Index?MaxPole:A_Index , Pole[A_Index, row] := 1
}
for i , obj in Pole {
TempVar:=0 , c := A_Index
for n, v in obj
TempVar += v
loop, % TempVar
TempObj[c, A_Index] := 1
}
loop, % Row {
TempVar:=0 , c := A_Index
Loop, % MaxPole
TempVar += TempObj[A_Index,c]
Result[c] := TempVar
}
return Result
}
Examples:
for i, val in BeadSort([54,12,87,56,36])
res := val (res?",":"") res
MsgBox % res
- Output:
12,36,54,56,87
BCPL
get "libhdr"
let max(A, len) = valof
$( let x = 0
for i=0 to len-1
if x<A!i do x := A!i
resultis x
$)
let beadsort(A, len) be
$( let size = max(A, len)
let tvec = getvec(size-1)
for i=0 to size-1 do tvec!i := 0
for i=0 to len-1
for j=0 to A!i-1 do tvec!j := tvec!j + 1
for i=len-1 to 0 by -1
$( let n = 0
for j=0 to size-1
if tvec!j > 0
$( tvec!j := tvec!j - 1
n := n + 1
$)
A!i := n
$)
freevec(tvec)
$)
let write(s, A, len) be
$( writes(s)
for i=0 to len-1 do writed(A!i, 4)
wrch('*N')
$)
let start() be
$( let array = table 10,1,5,5,9,2,20,6,8,4
let length = 10
write("Before: ", array, length)
beadsort(array, length)
write("After: ", array, length)
$)
- Output:
Before: 10 1 5 5 9 2 20 6 8 4 After: 1 2 4 5 5 6 8 9 10 20
C
A rather straightforward implementation; since we do not use dynamic matrix, we have to know the maximum value in the array in advance. Requires (max * length) bytes for beads; if memory is of concern, bytes can be replaced by bits.
#include <stdio.h>
#include <stdlib.h>
void bead_sort(int *a, int len)
{
int i, j, max, sum;
unsigned char *beads;
# define BEAD(i, j) beads[i * max + j]
for (i = 1, max = a[0]; i < len; i++)
if (a[i] > max) max = a[i];
beads = calloc(1, max * len);
/* mark the beads */
for (i = 0; i < len; i++)
for (j = 0; j < a[i]; j++)
BEAD(i, j) = 1;
for (j = 0; j < max; j++) {
/* count how many beads are on each post */
for (sum = i = 0; i < len; i++) {
sum += BEAD(i, j);
BEAD(i, j) = 0;
}
/* mark bottom sum beads */
for (i = len - sum; i < len; i++) BEAD(i, j) = 1;
}
for (i = 0; i < len; i++) {
for (j = 0; j < max && BEAD(i, j); j++);
a[i] = j;
}
free(beads);
}
int main()
{
int i, x[] = {5, 3, 1, 7, 4, 1, 1, 20};
int len = sizeof(x)/sizeof(x[0]);
bead_sort(x, len);
for (i = 0; i < len; i++)
printf("%d\n", x[i]);
return 0;
}
C++
//this algorithm only works with positive, whole numbers.
//O(2n) time complexity where n is the summation of the whole list to be sorted.
//O(3n) space complexity.
#include <iostream>
#include <vector>
using std::cout;
using std::vector;
void distribute(int dist, vector<int> &List) {
//*beads* go down into different buckets using gravity (addition).
if (dist > List.size() )
List.resize(dist); //resize if too big for current vector
for (int i=0; i < dist; i++)
List[i]++;
}
vector<int> beadSort(int *myints, int n) {
vector<int> list, list2, fifth (myints, myints + n);
cout << "#1 Beads falling down: ";
for (int i=0; i < fifth.size(); i++)
distribute (fifth[i], list);
cout << '\n';
cout << "\nBeads on their sides: ";
for (int i=0; i < list.size(); i++)
cout << " " << list[i];
cout << '\n';
//second part
cout << "#2 Beads right side up: ";
for (int i=0; i < list.size(); i++)
distribute (list[i], list2);
cout << '\n';
return list2;
}
int main() {
int myints[] = {734,3,1,24,324,324,32,432,42,3,4,1,1};
vector<int> sorted = beadSort(myints, sizeof(myints)/sizeof(int));
cout << "Sorted list/array: ";
for(unsigned int i=0; i<sorted.size(); i++)
cout << sorted[i] << ' ';
}
Clojure
(defn transpose [xs]
(loop [ret [], remain xs]
(if (empty? remain)
ret
(recur (conj ret (map first remain))
(filter not-empty (map rest remain))))))
(defn bead-sort [xs]
(->> xs
(map #(repeat % 1))
transpose
transpose
(map #(reduce + %))))
;; This algorithm does not work if collection has zero
(-> [5 2 4 1 3 3 9] bead-sort println)
- Output:
(9 5 4 3 3 2 1)
COBOL
>>SOURCE FORMAT FREE
*> This code is dedicated to the public domain
*> This is GNUCOBOL 2.0
identification division.
program-id. beadsort.
environment division.
configuration section.
repository. function all intrinsic.
data division.
working-storage section.
01 filler.
03 row occurs 9 pic x(9).
03 r pic 99.
03 r1 pic 99.
03 r2 pic 99.
03 pole pic 99.
03 a-lim pic 99 value 9.
03 a pic 99.
03 array occurs 9 pic 9.
01 NL pic x value x'0A'.
procedure division.
start-beadsort.
*> fill the array
compute a = random(seconds-past-midnight)
perform varying a from 1 by 1 until a > a-lim
compute array(a) = random() * 10
end-perform
perform display-array
display space 'initial array'
*> distribute the beads
perform varying r from 1 by 1 until r > a-lim
move all '.' to row(r)
perform varying pole from 1 by 1 until pole > array(r)
move 'o' to row(r)(pole:1)
end-perform
end-perform
display NL 'initial beads'
perform display-beads
*> drop the beads
perform varying pole from 1 by 1 until pole > a-lim
move a-lim to r2
perform find-opening
compute r1 = r2 - 1
perform find-bead
perform until r1 = 0 *> no bead or no opening
*> drop the bead
move '.' to row(r1)(pole:1)
move 'o' to row(r2)(pole:1)
*> continue up the pole
compute r2 = r2 - 1
perform find-opening
compute r1 = r2 - 1
perform find-bead
end-perform
end-perform
display NL 'dropped beads'
perform display-beads
*> count the beads in each row
perform varying r from 1 by 1 until r > a-lim
move 0 to array(r)
inspect row(r) tallying array(r)
for all 'o' before initial '.'
end-perform
perform display-array
display space 'sorted array'
stop run
.
find-opening.
perform varying r2 from r2 by -1
until r2 = 1 or row(r2)(pole:1) = '.'
continue
end-perform
.
find-bead.
perform varying r1 from r1 by -1
until r1 = 0 or row(r1)(pole:1) = 'o'
continue
end-perform
.
display-array.
display space
perform varying a from 1 by 1 until a > a-lim
display space array(a) with no advancing
end-perform
.
display-beads.
perform varying r from 1 by 1 until r > a-lim
display row(r)
end-perform
.
end program beadsort.
- Output:
prompt$ cobc -xj beadsort.cob 3 2 1 6 1 6 4 9 7 initial array initial beads ooo...... oo....... o........ oooooo... o........ oooooo... oooo..... ooooooooo ooooooo.. dropped beads o........ o........ oo....... ooo...... oooo..... oooooo... oooooo... ooooooo.. ooooooooo 1 1 2 3 4 6 6 7 9 sorted array
Common Lisp
(defun transpose (remain &optional (ret '()))
(if (null remain)
ret
(transpose (remove-if #'null (mapcar #'cdr remain))
(append ret (list (mapcar #'car remain))))))
(defun bead-sort (xs)
(mapcar #'length (transpose (transpose (mapcar (lambda (x) (make-list x :initial-element 1)) xs)))))
(bead-sort '(5 2 4 1 3 3 9))
- Output:
(9 5 4 3 3 2 1)
D
A functional-style solution.
import std.stdio, std.algorithm, std.range, std.array, std.functional;
alias repeat0 = curry!(repeat, 0);
// Currenty std.range.transposed doesn't work.
auto columns(R)(R m) pure /*nothrow*/ @safe /*@nogc*/ {
return m
.map!walkLength
.reduce!max
.iota
.map!(i => m.filter!(s => s.length > i).walkLength.repeat0);
}
auto beadSort(in uint[] data) pure /*nothrow @nogc*/ {
return data.map!repeat0.columns.columns.map!walkLength;
}
void main() {
[5, 3, 1, 7, 4, 1, 1].beadSort.writeln;
}
- Output:
[7, 5, 4, 3, 1, 1, 1]
Delphi
program BeadSortTest;
{$APPTYPE CONSOLE}
uses
SysUtils;
procedure BeadSort(var a : array of integer);
var
i, j, max, sum : integer;
beads : array of array of integer;
begin
max := a[Low(a)];
for i := Low(a) + 1 to High(a) do
if a[i] > max then
max := a[i];
SetLength(beads, High(a) - Low(a) + 1, max);
// mark the beads
for i := Low(a) to High(a) do
for j := 0 to a[i] - 1 do
beads[i, j] := 1;
for j := 0 to max - 1 do
begin
// count how many beads are on each post
sum := 0;
for i := Low(a) to High(a) do
begin
sum := sum + beads[i, j];
beads[i, j] := 0;
end;
//mark bottom sum beads
for i := High(a) + 1 - sum to High(a) do
beads[i, j] := 1;
end;
for i := Low(a) to High(a) do
begin
j := 0;
while (j < max) and (beads[i, j] <> 0) do
inc(j);
a[i] := j;
end;
SetLength(beads, 0, 0);
end;
const
N = 8;
var
i : integer;
x : array[1..N] of integer = (5, 3, 1, 7, 4, 1, 1, 20);
begin
for i := 1 to N do
writeln(Format('x[%d] = %d', [i, x[i]]));
BeadSort(x);
for i := 1 to N do
writeln(Format('x[%d] = %d', [i, x[i]]));
readln;
end.
--DavidIzadaR 18:12, 7 August 2011 (UTC)
Eiffel
class
BEAD_SORT
feature
bead_sort (ar: ARRAY [INTEGER]): ARRAY [INTEGER]
-- Sorted array in descending order.
require
only_positive_integers: across ar as a all a.item > 0 end
local
max, count, i, j, k: INTEGER
do
max := max_item (ar)
create Result.make_filled (0, 1, ar.count)
from
i := 1
until
i > max
loop
count := 0
from
k := 1
until
k > ar.count
loop
if ar.item (k) >= i then
count := count + 1
end
k := k + 1
end
from
j := 1
until
j > count
loop
Result [j] := i
j := j + 1
end
i := i + 1
end
ensure
array_is_sorted: is_sorted (Result)
end
feature {NONE}
max_item (ar: ARRAY [INTEGER]): INTEGER
-- Max item of 'ar'.
require
ar_not_void: ar /= Void
do
across
ar as a
loop
if a.item > Result then
Result := a.item
end
end
ensure
Result_is_max: across ar as a all a.item <= Result end
end
is_sorted (ar: ARRAY [INTEGER]): BOOLEAN
--- Is 'ar' sorted in descending order?
require
ar_not_empty: ar.is_empty = False
local
i: INTEGER
do
Result := True
from
i := ar.lower
until
i = ar.upper
loop
if ar [i] < ar [i + 1] then
Result := False
end
i := i + 1
end
end
end
Test:
class
APPLICATION
create
make
feature
make
do
test := <<1, 5, 99, 2, 95, 7, 7>>
create beadsort
io.put_string ("unsorted:" + "%N")
across
test as ar
loop
io.put_string (ar.item.out + "%T")
end
io.put_string ("%N" + "sorted:" + "%N")
test := beadsort.bead_sort (test)
across
test as ar
loop
io.put_string (ar.item.out + "%T")
end
end
beadsort: BEAD_SORT
test: ARRAY [INTEGER]
end
- Output:
unsorted: 1 5 99 2 95 7 7 sorted: 99 95 7 7 5 2 1
Elixir
defmodule Sort do
def bead_sort(list) when is_list(list), do: dist(dist(list))
defp dist(list), do: List.foldl(list, [], fn(n, acc) when n>0 -> dist(acc, n, []) end)
defp dist([], 0, acc), do: Enum.reverse(acc)
defp dist([h|t], 0, acc), do: dist(t, 0, [h |acc])
defp dist([], n, acc), do: dist([], n-1, [1 |acc])
defp dist([h|t], n, acc), do: dist(t, n-1, [h+1|acc])
end
Example:
iex(20)> Sort.bead_sort([5,3,9,4,1,6,8,2,7]) [9, 8, 7, 6, 5, 4, 3, 2, 1]
Erlang
-module(beadsort).
-export([sort/1]).
sort(L) ->
dist(dist(L)).
dist(L) when is_list(L) ->
lists:foldl(fun (N, Acc) -> dist(Acc, N, []) end, [], L).
dist([H | T], N, Acc) when N > 0 ->
dist(T, N - 1, [H + 1 | Acc]);
dist([], N, Acc) when N > 0 ->
dist([], N - 1, [1 | Acc]);
dist([H | T], 0, Acc) ->
dist(T, 0, [H | Acc]);
dist([], 0, Acc) ->
lists:reverse(Acc).
Example;
1> beadsort:sort([1,734,24,3,324,324,32,432,42,3,4,1,1]).
[734,432,324,324,42,32,24,4,3,3,1,1,1]
F#
open System
let removeEmptyLists lists = lists |> List.filter (not << List.isEmpty)
let flip f x y = f y x
let rec transpose = function
| [] -> []
| lists -> (List.map List.head lists) :: transpose(removeEmptyLists (List.map List.tail lists))
// Using the backward composition operator "<<" (equivalent to Haskells ".") ...
let beadSort = List.map List.sum << transpose << transpose << List.map (flip List.replicate 1)
// Using the forward composition operator ">>" ...
let beadSort2 = List.map (flip List.replicate 1) >> transpose >> transpose >> List.map List.sum
Usage: beadSort [2;4;1;3;3] or beadSort2 [2;4;1;3;3]
- Output:
val it : int list = [4; 3; 3; 2; 1]
Factor
USING: kernel math math.order math.vectors sequences ;
: fill ( seq len -- newseq ) [ dup length ] dip swap - 0 <repetition> append ;
: bead ( seq -- newseq )
dup 0 [ max ] reduce
[ swap 1 <repetition> swap fill ] curry map
[ ] [ v+ ] map-reduce ;
: beadsort ( seq -- newseq ) bead bead ;
( scratchpad ) { 5 2 4 1 3 3 9 } beadsort .
{ 9 5 4 3 3 2 1 }
Fortran
removing the iso_fortran_env as explained in code
This implementation suffers the same problems of the C implementation: if the maximum value in the array to be sorted is very huge, likely there will be not enough free memory to complete the task. Nonetheless, if the Fortran implementation would use "silently" sparse arrays and a compact representation for "sequences" of equal values in an array, then this very same code would run fine even with large integers.
program BeadSortTest
use iso_fortran_env
! for ERROR_UNIT; to make this a F95 code,
! remove prev. line and declare ERROR_UNIT as an
! integer parameter matching the unit associated with
! standard error
integer, dimension(7) :: a = (/ 7, 3, 5, 1, 2, 1, 20 /)
call beadsort(a)
print *, a
contains
subroutine beadsort(a)
integer, dimension(:), intent(inout) :: a
integer, dimension(maxval(a), maxval(a)) :: t
integer, dimension(maxval(a)) :: s
integer :: i, m
m = maxval(a)
if ( any(a < 0) ) then
write(ERROR_UNIT,*) "can't sort"
return
end if
t = 0
forall(i=1:size(a)) t(i, 1:a(i)) = 1 ! set up abacus
forall(i=1:m) ! let beads "fall"; instead of
s(i) = sum(t(:, i)) ! moving them one by one, we just
t(:, i) = 0 ! count how many should be at bottom,
t(1:s(i), i) = 1 ! and then "reset" and set only those
end forall
forall(i=1:size(a)) a(i) = sum(t(i,:))
end subroutine beadsort
end program BeadSortTest
FreeBASIC
#define MAXNUM 100
Sub beadSort(bs() As Long)
Dim As Long i, j = 1, lb = Lbound(bs), ub = Ubound(bs)
Dim As Long poles(MAXNUM)
For i = 1 To ub
For j = 1 To bs(i)
poles(j) += 1
Next j
Next i
For j = 1 To ub
bs(j) = 0
Next j
For i = 1 To Ubound(poles)
For j = 1 To poles(i)
bs(j) += 1
Next j
Next i
End Sub
'--- Programa Principal ---
Dim As Long i
Dim As Ulong array(1 To 8) => {5, 3, 1, 7, 4, 1, 1, 20}
Dim As Long a = Lbound(array), b = Ubound(array)
Randomize Timer
Print "unsort ";
For i = a To b : Print Using "####"; array(i); : Next i
beadSort(array())
Print !"\n sort ";
For i = a To b : Print Using "####"; array(i); : Next i
Print !"\n--- terminado, pulsa RETURN---"
Sleep
- Output:
unsort 5 3 1 7 4 1 1 20 sort 20 7 5 4 3 1 1 1
Go
Sorts non-negative integers only. The extension to negative values seemed a distraction from this fun task.
package main
import (
"fmt"
"sync"
)
var a = []int{170, 45, 75, 90, 802, 24, 2, 66}
var aMax = 1000
const bead = 'o'
func main() {
fmt.Println("before:", a)
beadSort()
fmt.Println("after: ", a)
}
func beadSort() {
// All space in the abacus = aMax poles x len(a) rows.
all := make([]byte, aMax*len(a))
// Slice up space by pole. (The space could be sliced by row instead,
// but slicing by pole seemed a more intuitive model of a physical abacus.)
abacus := make([][]byte, aMax)
for pole, space := 0, all; pole < aMax; pole++ {
abacus[pole] = space[:len(a)]
space = space[len(a):]
}
// Use a sync.Waitgroup as the checkpoint mechanism.
var wg sync.WaitGroup
// Place beads for each number concurrently. (Presumably beads can be
// "snapped on" to the middle of a pole without disturbing neighboring
// beads.) Also note 'row' here is a row of the abacus.
wg.Add(len(a))
for row, n := range a {
go func(row, n int) {
for pole := 0; pole < n; pole++ {
abacus[pole][row] = bead
}
wg.Done()
}(row, n)
}
wg.Wait()
// Now tip the abacus, letting beads fall on each pole concurrently.
wg.Add(aMax)
for _, pole := range abacus {
go func(pole []byte) {
// Track the top of the stack of beads that have already fallen.
top := 0
for row, space := range pole {
if space == bead {
// Move each bead individually, but move it from its
// starting row to the top of stack in a single operation.
// (More physical simulation such as discovering the top
// of stack by inspection, or modeling gravity, are
// possible, but didn't seem called for by the task.
pole[row] = 0
pole[top] = bead
top++
}
}
wg.Done()
}(pole)
}
wg.Wait()
// Read out sorted numbers by row.
for row := range a {
x := 0
for pole := 0; pole < aMax && abacus[pole][row] == bead; pole++ {
x++
}
a[len(a)-1-row] = x
}
}
Groovy
Solution:
def beadSort = { list ->
final nPoles = list.max()
list.collect {
print "."
([true] * it) + ([false] * (nPoles - it))
}.transpose().collect { pole ->
print "."
pole.findAll { ! it } + pole.findAll { it }
}.transpose().collect{ beadTally ->
beadTally.findAll{ it }.size()
}
}
Annotated Solution (same solution really):
def beadSortVerbose = { list ->
final nPoles = list.max()
// each row is a number tally-arrayed across the abacus
def beadTallies = list.collect { number ->
print "."
// true == bead, false == no bead
([true] * number) + ([false] * (nPoles - number))
}
// each row is an abacus pole
def abacusPoles = beadTallies.transpose()
def abacusPolesDrop = abacusPoles.collect { pole ->
print "."
// beads drop to the BOTTOM of the pole
pole.findAll { ! it } + pole.findAll { it }
}
// each row is a number again
def beadTalliesDrop = abacusPolesDrop.transpose()
beadTalliesDrop.collect{ beadTally -> beadTally.findAll{ it }.size() }
}
Test:
println beadSort([23,76,99,58,97,57,35,89,51,38,95,92,24,46,31,24,14,12,57,78,4])
println beadSort([88,18,31,44,4,0,8,81,14,78,20,76,84,33,73,75,82,5,62,70,12,7,1])
- Output:
........................................................................................................................[4, 12, 14, 23, 24, 24, 31, 35, 38, 46, 51, 57, 57, 58, 76, 78, 89, 92, 95, 97, 99] ...............................................................................................................[0, 1, 4, 5, 7, 8, 12, 14, 18, 20, 31, 33, 44, 62, 70, 73, 75, 76, 78, 81, 82, 84, 88]
Individual dots shown here are "retallying dots". They are not equivalent to the "swap dots" shown in other Groovy sorting examples. Like the swap dots the retallying dots represent atomic operations that visually indicate the overall sorting effort. However, they are not equivalent to swaps, or even equivalent in actual effort between bead sorts.
The cost of transposition is not accounted for here because with clever indexing it can easily be optimized away. In fact, one could write a list class for Groovy that performs the transpose operation merely by setting a single boolean value that controls indexing calculations.
Haskell
import Data.List
beadSort :: [Int] -> [Int]
beadSort = map sum. transpose. transpose. map (flip replicate 1)
Example;
*Main> beadSort [2,4,1,3,3]
[4,3,3,2,1]
Icon and Unicon
The program below handles integers and not just whole numbers. As are so many others, the solution is limited by the lack of sparse array or list compression.
Note: This example relies on the supporting procedures 'writex' in Bubble Sort. Note: min and max are available in the Icon Programming Library (IPL).
- Abbreviated sample output:
Sorting Demo using procedure beadsort on list : [ 3 14 1 5 9 2 6 3 ] with op = &null: [ 1 2 3 3 5 6 9 14 ] (0 ms)
J
bead=: [: +/ #"0&1
Example use:
bead bead 2 4 1 3 3
4 3 3 2 1
bead bead 5 3 1 7 4 1 1
7 5 4 3 1 1 1
Extending to deal with sequences of arbitrary integers:
bball=: ] (] + [: bead^:2 -) <./ - 1:
Example use:
bball 2 0 _1 3 1 _2 _3 0
3 2 1 0 0 _1 _2 _3
Java
public class BeadSort
{
public static void main(String[] args)
{
BeadSort now=new BeadSort();
int[] arr=new int[(int)(Math.random()*11)+5];
for(int i=0;i<arr.length;i++)
arr[i]=(int)(Math.random()*10);
System.out.print("Unsorted: ");
now.display1D(arr);
int[] sort=now.beadSort(arr);
System.out.print("Sorted: ");
now.display1D(sort);
}
int[] beadSort(int[] arr)
{
int max=a[0];
for(int i=1;i<arr.length;i++)
if(arr[i]>max)
max=arr[i];
//Set up abacus
char[][] grid=new char[arr.length][max];
int[] levelcount=new int[max];
for(int i=0;i<max;i++)
{
levelcount[i]=0;
for(int j=0;j<arr.length;j++)
grid[j][i]='_';
}
/*
display1D(arr);
display1D(levelcount);
display2D(grid);
*/
//Drop the beads
for(int i=0;i<arr.length;i++)
{
int num=arr[i];
for(int j=0;num>0;j++)
{
grid[levelcount[j]++][j]='*';
num--;
}
}
System.out.println();
display2D(grid);
//Count the beads
int[] sorted=new int[arr.length];
for(int i=0;i<arr.length;i++)
{
int putt=0;
for(int j=0;j<max&&grid[arr.length-1-i][j]=='*';j++)
putt++;
sorted[i]=putt;
}
return sorted;
}
void display1D(int[] arr)
{
for(int i=0;i<arr.length;i++)
System.out.print(arr[i]+" ");
System.out.println();
}
void display1D(char[] arr)
{
for(int i=0;i<arr.length;i++)
System.out.print(arr[i]+" ");
System.out.println();
}
void display2D(char[][] arr)
{
for(int i=0;i<arr.length;i++)
display1D(arr[i]);
System.out.println();
}
}
- Output:
Unsorted: 9 4 7 0 4 3 0 5 3 8 7 9 8 7 0 * * * * * * * * * * * * * * * * * * * * * * * * * * _ * * * * * * * * _ * * * * * * * _ _ * * * * * * * _ _ * * * * * * * _ _ * * * * * _ _ _ _ * * * * _ _ _ _ _ * * * * _ _ _ _ _ * * * _ _ _ _ _ _ * * * _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ Sorted: 0 0 0 3 3 4 4 5 7 7 7 8 8 9 9
jq
Part 1: The abacus This implementation uses an "abacus" as described in the Wikipedia article. However, rather than representing each row as a set of n beads, it suffices to use the integer n instead. Thus the initial state of our abacus is simply the array of numbers to be sorted. (A better approach would be to normalize the integers by subtracting their minimum value minus 1; that would also allow sorting arrays of integers without restriction.)
Part 2: Gravity
# ncols is the number of columns (i.e. vertical poles)
def column_sums(ncols):
. as $abacus
| reduce range(0; ncols) as $col
([];
. + [reduce $abacus[] as $row
(0; if $row > $col then .+1 else . end)]) ;
Part 3: read the answer in order of largest-to-smallest
# Generic function to count the number of items in a stream:
def count(stream): reduce stream as $i (0; .+1);
def readout:
. as $sums
| .[0] as $n
| reduce range(0;$n) as $i
([]; . + [count( $sums[] | select( . > $i) )]);
"Bead Sort":
def bead_sort: column_sums(max) | readout;
Example:
[734,3,1,24,324,324,32,432,42,3,4,1,1] | bead_sort
- Output:
$ jq -n -c -f bead_sort.jq
[734,432,324,324,42,32,24,4,3,3,1,1,1]
Julia
Implement beadsort
on a BitArray
abacus. The function should work for any integer type. It throws a DomainError
if the input array contains a non-positive integer.
function beadsort(a::Vector{<:Integer})
lo, hi = extrema(a)
if lo < 1 throw(DomainError()) end
len = length(a)
abacus = falses(len, hi)
for (i, v) in enumerate(a)
abacus[i, 1:v] = true
end
for i in 1:hi
v = sum(abacus[:, i])
if v < len
abacus[1:end-v, i] = false
abacus[end-v+1:end, i] = true
end
end
return collect(eltype(a), sum(abacus[i,:]) for i in 1:len)
end
v = rand(UInt8, 20)
println("# unsorted bytes: $v\n -> sorted bytes: $(beadsort(v))")
v = rand(1:2 ^ 10, 20)
println("# unsorted integers: $v\n -> sorted integers: $(beadsort(v))")
- Output:
# unsorted bytes: UInt8[0xff, 0x52, 0xdd, 0x72, 0xe2, 0x13, 0xb5, 0xd3, 0x7f, 0xea, 0x3b, 0x46, 0x4b, 0x78, 0xfb, 0xbe, 0xd8, 0x2e, 0xa9, 0x7a] -> sorted bytes: UInt8[0x13, 0x2e, 0x3b, 0x46, 0x4b, 0x52, 0x72, 0x78, 0x7a, 0x7f, 0xa9, 0xb5, 0xbe, 0xd3, 0xd8, 0xdd, 0xe2, 0xea, 0xfb, 0xff] # unsorted integers: [1012, 861, 798, 949, 481, 889, 78, 699, 718, 195, 426, 922, 762, 360, 1017, 208, 304, 13, 910, 854] -> sorted integers: [13, 78, 195, 208, 304, 360, 426, 481, 699, 718, 762, 798, 854, 861, 889, 910, 922, 949, 1012, 1017]
Kotlin
// version 1.1.2
fun beadSort(a: IntArray) {
val n = a.size
if (n < 2) return
var max = a.max()!!
val beads = ByteArray(max * n)
/* mark the beads */
for (i in 0 until n)
for (j in 0 until a[i])
beads[i * max + j] = 1
for (j in 0 until max) {
/* count how many beads are on each post */
var sum = 0
for (i in 0 until n) {
sum += beads[i * max + j]
beads[i * max + j] = 0
}
/* mark bottom sum beads */
for (i in n - sum until n) beads[i * max + j] = 1
}
for (i in 0 until n) {
var j = 0
while (j < max && beads[i * max + j] == 1.toByte()) j++
a[i] = j
}
}
fun main(args: Array<String>) {
val a = intArrayOf(5, 3, 1, 7, 4, 1, 1, 20)
println("Before sorting : ${a.contentToString()}")
beadSort(a)
println("After sorting : ${a.contentToString()}")
}
- Output:
Before sorting : [5, 3, 1, 7, 4, 1, 1, 20] After sorting : [1, 1, 1, 3, 4, 5, 7, 20]
Lua
-- Display message followed by all values of a table in one line
function show (msg, t)
io.write(msg .. ":\t")
for _, v in pairs(t) do io.write(v .. " ") end
print()
end
-- Return a table of random numbers
function randList (length, lo, hi)
local t = {}
for i = 1, length do table.insert(t, math.random(lo, hi)) end
return t
end
-- Count instances of numbers that appear in counting to each list value
function tally (list)
local tal = {}
for k, v in pairs(list) do
for i = 1, v do
if tal[i] then tal[i] = tal[i] + 1 else tal[i] = 1 end
end
end
return tal
end
-- Sort a table of positive integers into descending order
function beadSort (numList)
show("Before sort", numList)
local abacus = tally(numList)
show("Tally list", abacus)
local sorted = tally(abacus)
show("After sort", sorted)
end
-- Main procedure
math.randomseed(os.time())
beadSort(randList(10, 1, 10))
- Output:
Before sort: 9 5 3 9 4 1 3 8 1 2 Tally list: 10 8 7 5 4 3 3 3 2 After sort: 9 9 8 5 4 3 3 2 1 1
Mathematica /Wolfram Language
beadsort[ a ] := Module[ { m, sorted, s ,t },
sorted = a; m = Max[a]; t=ConstantArray[0, {m,m} ];
If[ Min[a] < 0, Print["can't sort"]];
For[ i = 1, i < Length[a], i++, t[[i,1;;a[[i]]]]=1 ]
For[ i = 1 ,i <= m, i++, s = Total[t[[;;,i]]];
t[[ ;; , i]] = 0; t[[1 ;; s , i]] = 1; ]
For[ i=1,i<=Length[a],i++, sorted[[i]] = Total[t[[i,;;]]]; ]
Print[sorted];
]
beadsort[{2,1,5,3,6}]
- Output:
{6,3,2,1,0}
NetRexx
/* NetRexx */
options replace format comments java crossref symbols nobinary
runSample(arg)
return
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
method bead_sort(harry = Rexx[]) public static binary returns Rexx[]
MIN_ = 'MIN'
MAX_ = 'MAX'
beads = Rexx 0
beads[MIN_] = 0
beads[MAX_] = 0
loop val over harry
-- collect occurences of beads in indexed string indexed on value
if val < beads[MIN_] then beads[MIN_] = val -- keep track of min value
if val > beads[MAX_] then beads[MAX_] = val -- keep track of max value
beads[val] = beads[val] + 1
end val
harry_sorted = Rexx[harry.length]
bi = 0
loop xx = beads[MIN_] to beads[MAX_]
-- extract beads in value order and insert in result array
if beads[xx] == 0 then iterate xx
loop for beads[xx]
harry_sorted[bi] = xx
bi = bi + 1
end
end xx
return harry_sorted
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
method runSample(arg) public static
unsorted = [734, 3, 1, 24, 324, -1024, -666, -1, 0, 324, 32, 0, 432, 42, 3, 4, 1, 1]
sorted = bead_sort(unsorted)
say arrayToString(unsorted)
say arrayToString(sorted)
return
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
method arrayToString(harry = Rexx[]) private static
list = Rexx ''
loop vv over harry
list = list vv
end vv
return '['list.space(1, ',')']'
- Output:
[734,3,1,24,324,-1024,-666,-1,0,324,32,0,432,42,3,4,1,1] [-1024,-666,-1,0,0,1,1,1,3,3,4,24,32,42,324,324,432,734]
Nim
proc beadSort[T](a: var openarray[T]) =
var max = low(T)
var sum = 0
for x in a:
if x > max: max = x
var beads = newSeq[int](max * a.len)
for i in 0 ..< a.len:
for j in 0 ..< a[i]:
beads[i * max + j] = 1
for j in 0 ..< max:
sum = 0
for i in 0 ..< a.len:
sum += beads[i * max + j]
beads[i * max + j] = 0
for i in a.len - sum ..< a.len:
beads[i * max + j] = 1
for i in 0 ..< a.len:
var j = 0
while j < max and beads[i * max + j] > 0: inc j
a[i] = j
var a = @[5, 3, 1, 7, 4, 1, 1, 20]
beadSort a
echo a
- Output:
@[1, 1, 1, 3, 4, 5, 7, 20]
OCaml
let rec columns l =
match List.filter ((<>) []) l with
[] -> []
| l -> List.map List.hd l :: columns (List.map List.tl l)
let replicate n x = Array.to_list (Array.make n x)
let bead_sort l =
List.map List.length (columns (columns (List.map (fun e -> replicate e 1) l)))
usage
# bead_sort [5;3;1;7;4;1;1];; - : int list = [7; 5; 4; 3; 1; 1; 1]
Octave
function sorted = beadsort(a)
sorted = a;
m = max(a);
if ( any(a < 0) )
error("can't sort");
endif
t = zeros(m, m);
for i = 1:numel(a)
t(i, 1:a(i)) = 1;
endfor
for i = 1:m
s = sum(t(:, i));
t(:, i) = 0;
t(1:s, i) = 1;
endfor
for i = 1:numel(a)
sorted(i) = sum(t(i, :));
endfor
endfunction
beadsort([5, 7, 1, 3, 1, 1, 20])
ooRexx
version 1
in='10 -12 1 0 999 8 2 2 4 4'
Do i=1 To words(in)
z.i=word(in,i)
End
n=i-1
init=0
Call minmax
beads.=0;
Do i=1 To words(in)
z=z.i
beads.z+=1
End
j=0
Do i=lo To hi
Do While beads.i>0
j+=1
s.j=i
beads.i-=1
End;
End;
Call show ' Input:',z.,n
Call show 'Sorted:',s.,n
Exit
minmax:
Do i=1 To n
If init=0 Then Do
init=1
lo=z.i
hi=z.i
End
Else Do
lo=min(lo,z.i)
hi=max(hi,z.i)
End
End
Return
show: Procedure Expose n
Use Arg txt,a.
ol=txtg>
Do i=1 To n
ol=ol format(a.i,3)
End
Say ol
Return
- Output:
Input: 10 -12 1 0 999 8 2 2 4 4 Sorted: -12 0 1 2 2 4 4 8 10 999
version 2
Note: The only changes needed were to substitute _, ! and ? characters for the "deprecated" $, # and @ characters within variable names; as per The REXX Language, Second Edition by M. F. Cowlishaw. (See a description here).
/*REXX program sorts a list of integers using a bead sort. */
/*get some grassHopper numbers. */
grasshopper=,
1 4 10 12 22 26 30 46 54 62 66 78 94 110 126 134 138 158 162 186 190 222 254 270
/*GreeenGrocer numbers are also called hexagonal pyramidal */
/* numbers. */
greengrocer=,
0 4 16 40 80 140 224 336 480 660 880 1144 1456 1820 2240 2720 3264 3876 4560
/*get some Bernoulli numerator numbers. */
bernN='1 -1 1 0 -1 0 1 0 -1 0 5 0 -691 0 7 0 -3617 0 43867 0 -174611 0 854513'
/*Psi is also called the Reduced Totient function, and */
/* is also called Carmichale lambda, or LAMBDA function.*/
psi=,
1 1 2 2 4 2 6 2 6 4 10 2 12 6 4 4 16 6 18 4 6 10 22 2 20 12 18 6 28 4 30 8 10 16
list=grasshopper greengrocer bernN psi /*combine the four lists into one*/
call showL 'before sort',list /*show list before sorting. */
!=beadSort(list) /*invoke the bead sort. */
call showL ' after sort',! /*show after array elements*/
exit
/*─────────────────────────────────beadSort@ subroutine────────────*/
beadSort: procedure expose _.
parse arg z
!='' /*this'll be the sorted list*/
low=999999999; high=-low /*define the low and high #s*/
_.=0 /*define all beads to zero. */
do j=1 until z=='' /*pick the meat off the bone*/
parse var z x z
if \datatype(x,'Whole') then
do
say
say '*** error! ***'
say
say 'element' j "in list isn't numeric:" x
say
exit 13
end
x=x/1 /*normalize number, it could*/
/*be: +4 007 5. 2e3 etc.*/
_.x=_.x+1 /*indicate this bead has a #*/
low=min(low,x) /*keep track of the lowest #*/
high=max(high,x) /* " " " " highest#*/
end j
/*now, collect the beads and*/
do m=low to high /*let them fall (to zero). */
if _.m==0 then iterate /*No bead here? Keep looking*/
do n=1 for _.m /*let the beads fall to 0. */
!=! m /*add it to the sorted list.*/
end n
end m
return !
/*─────────────────────────────────────SHOW@ subroutine────────────*/
showL:
widthH=length(words(arg(2))) /*maximum width of the index*/
do j=1 for words(arg(2))
say 'element' right(j,widthH) arg(1)":" right(word(arg(2),j),10)
end j
say copies('─',80) /*show a separator line. */
return
- Output:
element 1 before sort: 1 element 2 before sort: 4 element 3 before sort: 10 element 4 before sort: 12 element 5 before sort: 22 element 6 before sort: 26 element 7 before sort: 30 element 8 before sort: 46 element 9 before sort: 54 element 10 before sort: 62 element 11 before sort: 66 element 12 before sort: 78 element 13 before sort: 94 element 14 before sort: 110 element 15 before sort: 126 element 16 before sort: 134 element 17 before sort: 138 element 18 before sort: 158 element 19 before sort: 162 element 20 before sort: 186 element 21 before sort: 190 element 22 before sort: 222 element 23 before sort: 254 element 24 before sort: 270 element 25 before sort: 0 element 26 before sort: 4 element 27 before sort: 16 element 28 before sort: 40 element 29 before sort: 80 element 30 before sort: 140 element 31 before sort: 224 element 32 before sort: 336 element 33 before sort: 480 element 34 before sort: 660 element 35 before sort: 880 element 36 before sort: 1144 element 37 before sort: 1456 element 38 before sort: 1820 element 39 before sort: 2240 element 40 before sort: 2720 element 41 before sort: 3264 element 42 before sort: 3876 element 43 before sort: 4560 element 44 before sort: 1 element 45 before sort: -1 element 46 before sort: 1 element 47 before sort: 0 element 48 before sort: -1 element 49 before sort: 0 element 50 before sort: 1 element 51 before sort: 0 element 52 before sort: -1 element 53 before sort: 0 element 54 before sort: 5 element 55 before sort: 0 element 56 before sort: -691 element 57 before sort: 0 element 58 before sort: 7 element 59 before sort: 0 element 60 before sort: -3617 element 61 before sort: 0 element 62 before sort: 43867 element 63 before sort: 0 element 64 before sort: -174611 element 65 before sort: 0 element 66 before sort: 854513 element 67 before sort: 1 element 68 before sort: 1 element 69 before sort: 2 element 70 before sort: 2 element 71 before sort: 4 element 72 before sort: 2 element 73 before sort: 6 element 74 before sort: 2 element 75 before sort: 6 element 76 before sort: 4 element 77 before sort: 10 element 78 before sort: 2 element 79 before sort: 12 element 80 before sort: 6 element 81 before sort: 4 element 82 before sort: 4 element 83 before sort: 16 element 84 before sort: 6 element 85 before sort: 18 element 86 before sort: 4 element 87 before sort: 6 element 88 before sort: 10 element 89 before sort: 22 element 90 before sort: 2 element 91 before sort: 20 element 92 before sort: 12 element 93 before sort: 18 element 94 before sort: 6 element 95 before sort: 28 element 96 before sort: 4 element 97 before sort: 30 element 98 before sort: 8 element 99 before sort: 10 element 100 before sort: 16 ──────────────────────────────────────────────────────────────────────────────── element 1 after sort: -174611 element 2 after sort: -3617 element 3 after sort: -691 element 4 after sort: -1 element 5 after sort: -1 element 6 after sort: -1 element 7 after sort: 0 element 8 after sort: 0 element 9 after sort: 0 element 10 after sort: 0 element 11 after sort: 0 element 12 after sort: 0 element 13 after sort: 0 element 14 after sort: 0 element 15 after sort: 0 element 16 after sort: 0 element 17 after sort: 0 element 18 after sort: 1 element 19 after sort: 1 element 20 after sort: 1 element 21 after sort: 1 element 22 after sort: 1 element 23 after sort: 1 element 24 after sort: 2 element 25 after sort: 2 element 26 after sort: 2 element 27 after sort: 2 element 28 after sort: 2 element 29 after sort: 2 element 30 after sort: 4 element 31 after sort: 4 element 32 after sort: 4 element 33 after sort: 4 element 34 after sort: 4 element 35 after sort: 4 element 36 after sort: 4 element 37 after sort: 4 element 38 after sort: 5 element 39 after sort: 6 element 40 after sort: 6 element 41 after sort: 6 element 42 after sort: 6 element 43 after sort: 6 element 44 after sort: 6 element 45 after sort: 7 element 46 after sort: 8 element 47 after sort: 10 element 48 after sort: 10 element 49 after sort: 10 element 50 after sort: 10 element 51 after sort: 12 element 52 after sort: 12 element 53 after sort: 12 element 54 after sort: 16 element 55 after sort: 16 element 56 after sort: 16 element 57 after sort: 18 element 58 after sort: 18 element 59 after sort: 20 element 60 after sort: 22 element 61 after sort: 22 element 62 after sort: 26 element 63 after sort: 28 element 64 after sort: 30 element 65 after sort: 30 element 66 after sort: 40 element 67 after sort: 46 element 68 after sort: 54 element 69 after sort: 62 element 70 after sort: 66 element 71 after sort: 78 element 72 after sort: 80 element 73 after sort: 94 element 74 after sort: 110 element 75 after sort: 126 element 76 after sort: 134 element 77 after sort: 138 element 78 after sort: 140 element 79 after sort: 158 element 80 after sort: 162 element 81 after sort: 186 element 82 after sort: 190 element 83 after sort: 222 element 84 after sort: 224 element 85 after sort: 254 element 86 after sort: 270 element 87 after sort: 336 element 88 after sort: 480 element 89 after sort: 660 element 90 after sort: 880 element 91 after sort: 1144 element 92 after sort: 1456 element 93 after sort: 1820 element 94 after sort: 2240 element 95 after sort: 2720 element 96 after sort: 3264 element 97 after sort: 3876 element 98 after sort: 4560 element 99 after sort: 43867 element 100 after sort: 854513 ────────────────────────────────────────────────────────────────────────────────
OpenEdge/Progress
Sorting algorithms are not the kind of thing you need / want to do in OpenEdge. If you want to sort simply define a temp-table with one field, populate it and get sorted results with FOR EACH temp-table DESCENDING.
FUNCTION beadSort RETURNS CHAR (
i_c AS CHAR
):
DEF VAR cresult AS CHAR.
DEF VAR ii AS INT.
DEF VAR inumbers AS INT.
DEF VAR irod AS INT.
DEF VAR irods AS INT.
DEF VAR crod AS CHAR.
DEF VAR cbeads AS CHAR EXTENT.
inumbers = NUM-ENTRIES( i_c ).
/* determine number of rods needed */
DO ii = 1 TO inumbers:
irods = MAXIMUM( irods, INTEGER( ENTRY( ii, i_c ) ) ).
END.
/* put beads on rods */
EXTENT( cbeads ) = inumbers.
DO ii = 1 TO inumbers:
cbeads[ ii ] = FILL( "X", INTEGER( ENTRY( ii, i_c ) ) ).
END.
/* drop beads on each rod */
DO irod = 1 TO irods:
crod = "".
DO ii = 1 TO inumbers:
crod = crod + SUBSTRING( cbeads[ ii ], irod, 1 ).
END.
crod = REPLACE( crod, " ", "" ).
DO ii = 1 TO inumbers.
SUBSTRING( cbeads[ ii ], irod, 1 ) = STRING( ii <= LENGTH( crod ), "X/ " ).
END.
END.
/* get beads from rods */
DO ii = 1 TO inumbers:
cresult = cresult + "," + STRING( LENGTH( REPLACE( cbeads[ ii ], " ", "" ) ) ).
END.
RETURN SUBSTRING( cresult, 2 ).
END FUNCTION. /* beadSort */
MESSAGE
"5,2,4,1,3,3,9 -> " beadSort( "5,2,4,1,3,3,9" ) SKIP
"5,3,1,7,4,1,1 -> " beadSort( "5,3,1,7,4,1,1" ) SKIP(1)
beadSort( "88,18,31,44,4,0,8,81,14,78,20,76,84,33,73,75,82,5,62,70,12,7,1" )
VIEW-AS ALERT-BOX.
- Output:
--------------------------- Message --------------------------- 5,2,4,1,3,3,9 -> 9,5,4,3,3,2,1 5,3,1,7,4,1,1 -> 7,5,4,3,1,1,1 88,84,82,81,78,76,75,73,70,62,44,33,31,20,18,14,12,8,7,5,4,1,0 --------------------------- OK ---------------------------
PARI/GP
This implementation uses the counting sort to order the beads in a given row.
beadsort(v)={
my(sz=vecmax(v),M=matrix(#v,sz,i,j,v[i]>=j)); \\ Set up beads
for(i=1,sz,M[,i]=countingSort(M[,i],0,1)~); \\ Let them fall
vector(#v,i,value(M[i,])) \\ Convert back to numbers
};
countingSort(v,mn,mx)={
my(u=vector(#v),i=0);
for(n=mn,mx,
for(j=1,#v,if(v[j]==n,u[i++]=n))
);
u
};
value(v)={
if(#v==0 || !v[1], return(0));
if(v[#v], return(#v));
my(left=1, right=#v, mid);
while (right - left > 1,
mid=(right+left)\2;
if(v[mid], left=mid, right=mid)
);
left
};
Pascal
program BDS;
const MAX = 1000;
type
type_matrix = record
lin,col:integer;
matrix: array [1..MAX,1..MAX] of boolean;
end;
type_vector = record
size:integer;
vector: array[1..MAX] of integer;
end;
procedure BeadSort(var v:type_vector);
var
i,j,k,sum:integer;
m:type_matrix;
begin
m.lin:=v.size;
(* the number of columns is equal to the greatest element *)
m.col:=0;
for i:=1 to v.size do
if v.vector[i] > m.col then
m.col:=v.vector[i];
(* initializing the matrix *)
for j:=1 to m.lin do
begin
k:=1;
for i:=m.col downto 1 do
begin
if v.vector[j] >= k then
m.matrix[i,j]:=TRUE
else
m.matrix[i,j]:=FALSE;
k:=k+1;
end;
end;
(* Sort the matrix *)
for i:=1 to m.col do
begin
(* Count the beads and set the line equal FALSE *)
sum:=0;
for j:=1 to m.lin do
begin
if m.matrix[i,j] then
sum:=sum+1;
m.matrix[i,j]:=FALSE;
end;
(* The line receives the bead sorted *)
for j:=m.lin downto m.lin-sum+1 do
m.matrix[i,j]:=TRUE;
end;
(* Convert the sorted bead matrix to a sorted vector *)
for j:=1 to m.lin do
begin
v.vector[j]:=0;
i:=m.col;
while (m.matrix[i,j] = TRUE)and(i>=1) do
begin
v.vector[j]+=1;
i:=i-1;
end;
end;
end;
procedure print_vector(var v:type_vector);
var i:integer;
begin
for i:=1 to v.size do
write(v.vector[i],' ');
writeln;
end;
var
i:integer;
v:type_vector;
begin
writeln('How many numbers do you want to sort?');
readln(v.size);
writeln('Write the numbers:');
for i:=1 to v.size do
read(v.vector[i]);
writeln('Before sort:');
print_vector(v);
BeadSort(v);
writeln('After sort:');
print_vector(v);
end.
- Output:
How many numbers do you want to sort? 10 Write the numbers: 23 13 99 45 26 7 63 214 87 45 Before sort: 23 13 99 45 26 7 63 214 87 45 After sort: 7 13 23 26 45 45 63 87 99 214
Perl
Instead of storing the bead matrix explicitly, I choose to store just the number of beads in each row and column, compacting on the fly. At all times, the sum of the row widths is equal to the sum column heights.
sub beadsort {
my @data = @_;
my @columns;
my @rows;
for my $datum (@data) {
for my $column ( 0 .. $datum-1 ) {
++ $rows[ $columns[$column]++ ];
}
}
return reverse @rows;
}
beadsort 5, 7, 1, 3, 1, 1, 20;
Phix
with javascript_semantics function beadsort(sequence a) sequence poles = repeat(0,max(a)) for i=1 to length(a) do poles[1..a[i]] = sq_add(poles[1..a[i]],1) end for a[1..$] = 0 for i=1 to length(poles) do a[1..poles[i]] = sq_add(a[1..poles[i]],1) end for return a end function ?beadsort({5, 3, 1, 7, 4, 1, 1, 20})
- Output:
{20,7,5,4,3,1,1,1}
PHP
<?php
function columns($arr) {
if (count($arr) == 0)
return array();
else if (count($arr) == 1)
return array_chunk($arr[0], 1);
array_unshift($arr, NULL);
// array_map(NULL, $arr[0], $arr[1], ...)
$transpose = call_user_func_array('array_map', $arr);
return array_map('array_filter', $transpose);
}
function beadsort($arr) {
foreach ($arr as $e)
$poles []= array_fill(0, $e, 1);
return array_map('count', columns(columns($poles)));
}
print_r(beadsort(array(5,3,1,7,4,1,1)));
?>
- Output:
Array ( [0] => 7 [1] => 5 [2] => 4 [3] => 3 [4] => 1 [5] => 1 [6] => 1 )
PicoLisp
The following implements a direct model of the bead sort algorithm. Each pole is a list of 'T' symbols for the beads.
(de beadSort (Lst)
(let Abacus (cons NIL)
(for N Lst # Thread beads on poles
(for (L Abacus (ge0 (dec 'N)) (cdr L))
(or (cdr L) (queue 'L (cons)))
(push (cadr L) T) ) )
(make
(while (gt0 (cnt pop (cdr Abacus))) # Drop and count beads
(link @) ) ) ) )
- Output:
: (beadSort (5 3 1 7 4 1 1 20)) -> (20 7 5 4 3 1 1 1)
PL/I
version 1
/* Handles both negative and positive values. */
maxval: procedure (z) returns (fixed binary);
declare z(*) fixed binary;
declare (maxv initial (0), i) fixed binary;
do i = lbound(z,1) to hbound(z,1);
maxv = max(z(i), maxv);
end;
put skip data (maxv); put skip;
return (maxv);
end maxval;
minval: procedure (z) returns (fixed binary);
declare z(*) fixed binary;
declare (minv initial (0), i) fixed binary;
do i = lbound(z,1) to hbound(z,1);
if z(i) < 0 then minv = min(z(i), minv);
end;
put skip data (minv); put skip;
return (minv);
end minval;
/* To deal with negative values, array elements are incremented */
/* by the greatest (in magnitude) negative value, thus making */
/* them positive. The resultant values are stored in an */
/* unsigned array (PL/I provides both signed and unsigned data */
/* types). At procedure end, the array values are restored to */
/* original values. */
(subrg, fofl, size, stringrange, stringsize):
beadsort: procedure (z); /* 8-1-2010 */
declare (z(*)) fixed binary;
declare b(maxval(z)-minval(z)+1) bit (maxval(z)-minval(z)+1) aligned;
declare (i, j, k, m, n) fixed binary;
declare a(hbound(z,1)) fixed binary unsigned;
declare offset fixed binary initial (minval(z));
PUT SKIP LIST('CHECKPOINT A'); PUT SKIP;
n = hbound(z,1);
m = hbound(b,1);
if offset < 0 then
a = z - offset;
else
a = z;
b = '0'b;
do i = 1 to n;
substr(b(i), 1, a(i)) = copy('1'b, a(i));
end;
do j = 1 to m; put skip list (b(j)); end;
do j = 1 to m;
k = 0;
do i =1 to n;
if substr(b(i), j, 1) then k = k + 1;
end;
do i = 1 to n;
substr(b(i), j, 1) = (i <= k);
end;
end;
put skip;
do j = 1 to m; put skip list (b(j)); end;
do i = 1 to n;
k = 0;
do j = 1 to m; k = k + substr(b(i), j, 1); end;
a(i) = k;
end;
if offset < 0 then z = a + offset; else z = a;
end beadsort;
version 2
PL/I supports negative array indices!
*process source attributes xref;
/* Handles both negative and positive values. */
Beadsort: Proc Options(main);
Dcl sysprint Print;
Dcl (hbound,max,min) Builtin;
Dcl z(10) Bin Fixed(31) Init(10,-12,1,0,999,8,2,2,4,4);
Dcl s(10) Bin Fixed(31);
Dcl (init,lo,hi) Bin Fixed(31) Init(0);
Dcl (i,j) Bin Fixed(31) Init(0);
Call minmax(z,init,lo,hi);
Begin;
Dcl beads(lo:hi) Bin Fixed(31);
beads=0;
Do i=1 To hbound(z);
beads(z(i))+=1;
End;
Do i=lo To hi;
Do While(beads(i)>0);
j+=1;
s(j)=i;
beads(i)-=1;
End;
End;
Put Edit(' Input:',(z(i) Do i=1 To hbound(z)))(skip,a,99(f(4)));
Put Edit('Sorted:',(s(i) Do i=1 To hbound(s)))(skip,a,99(f(4)));
End;
minmax: Proc(z,init,lo,hi);
Dcl z(*) Bin Fixed(31);
Dcl (init,lo,hi) Bin Fixed(31);
Do i=1 To hbound(z);
If init=0 Then Do;
init=1;
lo,hi=z(i);
End;
Else Do;
lo=min(lo,z(i));
hi=max(hi,z(i));
End;
End;
End;
End;
- Output:
Input: 10 -12 1 0 999 8 2 2 4 4 Sorted: -12 0 1 2 2 4 4 8 10 999
PowerShell
Function BeadSort ( [Int64[]] $indata )
{
if( $indata.length -gt 1 )
{
$min = $indata[ 0 ]
$max = $indata[ 0 ]
for( $i = 1; $i -lt $indata.length; $i++ )
{
if( $indata[ $i ] -lt $min )
{
$min = $indata[ $i ]
}
if( $indata[ $i ] -gt $max ) {
$max = $indata[ $i ]
}
} #Find the min & max
$poles = New-Object 'UInt64[]' ( $max - $min + 1 )
$indata | ForEach-Object {
$min..$_ | ForEach-Object {
$poles[ $_ - $min ] += 1
}
} #Add Beads to the poles, already moved to the bottom
$min..( $max - 1 ) | ForEach-Object {
$i = $_ - $min
if( $poles[ $i ] -gt $poles[ $i + 1 ] )
{ #No special case needed for min, since there will always be at least 1 = min
( $poles[ $i ] )..( $poles[ $i + 1 ] + 1 ) | ForEach-Object {
Write-Output ( $i + $min )
}
}
} #Output the results in pipeline fashion
1..( $poles[ $max - $min ] ) | ForEach-Object {
Write-Output $max #No special case needed for max, since there will always be at least 1 = max
}
} else {
Write-Output $indata
}
}
$l = 100; BeadSort ( 1..$l | ForEach-Object { $Rand = New-Object Random }{ $Rand.Next( -( $l - 1 ), $l - 1 ) } )
PureBasic
#MAXNUM=100
Dim MyData(Random(15)+5)
Global Dim Abacus(0,0)
Declare BeadSort(Array InData(1))
Declare PresentData(Array InData(1))
If OpenConsole()
Define i
;- Generate a random array
For i=0 To ArraySize(MyData())
MyData(i)=Random(#MAXNUM)
Next i
PresentData(MyData())
;
;- Sort the array
BeadSort(MyData())
PresentData(MyData())
;
Print("Press ENTER to exit"): Input()
EndIf
Procedure LetFallDown(x)
Protected y=ArraySize(Abacus(),2)-1
Protected ylim=y
While y>=0
If Abacus(x,y) And Not Abacus(x,y+1)
Swap Abacus(x,y), Abacus(x,y+1)
If y<ylim: y+1: Continue: EndIf
Else
y-1
EndIf
Wend
EndProcedure
Procedure BeadSort(Array n(1))
Protected i, j, k
NewList T()
Dim Abacus(#MAXNUM,ArraySize(N()))
;- Set up the abacus
For i=0 To ArraySize(Abacus(),2)
For j=1 To N(i)
Abacus(j,i)=#True
Next
Next
;- sort it in threads to simulate free beads falling down
For i=0 To #MAXNUM
AddElement(T()): T()=CreateThread(@LetFallDown(),i)
Next
ForEach T()
WaitThread(T())
Next
;- send it back to a normal array
For j=0 To ArraySize(Abacus(),2)
k=0
For i=0 To ArraySize(Abacus())
k+Abacus(i,j)
Next
N(j)=k
Next
EndProcedure
Procedure PresentData(Array InData(1))
Protected n, m, sum
PrintN(#CRLF$+"The array is;")
For n=0 To ArraySize(InData())
m=InData(n): sum+m
Print(Str(m)+" ")
Next
PrintN(#CRLF$+"And its sum= "+Str(sum))
EndProcedure
The array is; 4 38 100 25 69 69 16 8 59 71 53 33 And its sum= 545 The array is; 4 8 16 25 33 38 53 59 69 69 71 100 And its sum= 545
Python
#!/bin/python3
from itertools import zip_longest
# This is wrong, it works only on specific examples
def beadsort(l):
return list(map(sum, zip_longest(*[[1] * e for e in l], fillvalue=0)))
# Demonstration code:
print(beadsort([5,3,1,7,4,1,1]))
- Output:
[7, 5, 4, 3, 1, 1, 1]
QB64
#lang QB64
'***************************************************
'* BeadSort is VERY fast for small CGSortLibArray(max)-CGSortLibArray(min). Typical performance is
'* O(NlogN) or better. However as the key values (array values and ranges) go up, the performance
'* drops steeply excellent for small-ranged arrays. Integer only at this point. Throughput is
'* roughly 900k/GHzS for double-precision, with binary range (0,1). Related to CountingSort()
'***************************************************
SUB BeadSort (CGSortLibArray() AS DOUBLE, start AS LONG, finish AS LONG, order&)
DIM MAX AS DOUBLE: MAX = CGSortLibArray(start)
DIM BeadSort_Sum AS DOUBLE
DIM BeadSort_I AS LONG
DIM BeadSort_J AS LONG
FOR BeadSort_I = start + 1 TO (finish - start)
IF (CGSortLibArray(BeadSort_I) > MAX) THEN MAX = CGSortLibArray(BeadSort_I)
NEXT
REDIM beads((finish - start), MAX)
FOR BeadSort_I = 0 TO (finish - start) - 1
FOR BeadSort_J = 0 TO CGSortLibArray(BeadSort_I) - 1
beads(BeadSort_I, BeadSort_J) = 1
NEXT
NEXT
IF order& = 1 THEN
FOR BeadSort_J = 0 TO MAX
BeadSort_Sum = 0
FOR BeadSort_I = 0 TO (finish - start)
BeadSort_Sum = BeadSort_Sum + beads(BeadSort_I, BeadSort_J)
beads(BeadSort_I, BeadSort_J) = 0
NEXT
FOR BeadSort_I = (finish - start) - BeadSort_Sum TO (finish - start)
beads(BeadSort_I, BeadSort_J) = 1
NEXT
NEXT
FOR BeadSort_I = 0 TO (finish - start)
BeadSort_J = 0
WHILE BeadSort_J < MAX AND beads(BeadSort_I, BeadSort_J)
BeadSort_J = BeadSort_J + 1
WEND
CGSortLibArray(BeadSort_I) = BeadSort_J
NEXT
ELSE
FOR BeadSort_J = MAX TO 0 STEP -1
BeadSort_Sum = 0
FOR I = 0 TO (finish - start)
BeadSort_Sum = BeadSort_Sum + beads(I, BeadSort_J)
beads(I, BeadSort_J) = 0
NEXT
FOR I = (finish - start) TO (finish - start) - BeadSort_Sum STEP -1
beads(I, BeadSort_J) = 1
NEXT
NEXT
FOR BeadSort_I = 0 TO (finish - start)
BeadSort_J = 0
WHILE BeadSort_J < MAX AND beads(BeadSort_I, BeadSort_J)
BeadSort_J = BeadSort_J + 1
WEND
CGSortLibArray(finish - BeadSort_I) = BeadSort_J
NEXT
END IF
END SUB
Racket
#lang racket
(require rackunit)
(define (columns lst)
(match (filter (λ (l) (not (empty? l))) lst)
['() '()]
[l (cons (map car l) (columns (map cdr l)))]))
(define (bead-sort lst)
(map length (columns (columns (map (λ (n) (make-list n 1)) lst)))))
;; unit test
(check-equal?
(bead-sort '(5 3 1 7 4 1 1))
'(7 5 4 3 1 1 1))
Raku
(formerly Perl 6)
# routine cribbed from List::Utils;
sub transpose(@list is copy) {
gather {
while @list {
my @heads;
if @list[0] !~~ Positional { @heads = @list.shift; }
else { @heads = @list.map({$_.shift unless $_ ~~ []}); }
@list = @list.map({$_ unless $_ ~~ []});
take [@heads];
}
}
}
sub beadsort(@l) {
(transpose(transpose(map {[1 xx $_]}, @l))).map(*.elems);
}
my @list = 2,1,3,5;
say beadsort(@list).perl;
- Output:
(5, 3, 2, 1)
Here we simulate the dropping beads by using the push method.
sub beadsort(*@list) {
my @rods;
for words ^«@list -> $x { @rods[$x].push(1) }
gather for ^@rods[0] -> $y {
take [+] @rods.map: { .[$y] // last }
}
}
say beadsort 2,1,3,5;
The ^ is the "upto" operator that gives a range of 0 up to (but not including) its endpoint. We use it as a hyperoperator (^«) to generate all the ranges of rod numbers we should drop a bead on, with the result that $x tells us which rod to drop each bead on. Then we use ^ again on the first rod to see how deep the beads are stacked, since they are guaranteed to be the deepest there. The [+] adds up all the beads that are found at level $y. The last short circuits the map so we don't have to look for all the missing beads at a given level, since the missing beads are all guaranteed to come after the existing beads at that level (because we always dropped left to right starting at rod 0).
REXX
The REXX language has the advantage of supporting sparse arrays, so implementing a bead sort is trivial, the
major drawback is if the spread (difference between the lowest and highest values) is quite large (if it's
greater than a few million), it'll slow up the display (but not the sorting).
Zero, negative, and duplicate integers (values) can be handled.
/*REXX program sorts a list (4 groups) of integers using the bead sort algorithm. */
/* original source by Gerard Schildberger */
/* 20230605 Walter Pachl reformatted and refurbished */
/* define two dozen grasshopper numbers. */
/* source ?? */
gHopper=1 4 10 12 22 26 30 46 54 62 66 78 94 110 126 134 138 158 162 186 190 222 254,
270
/* these are also called hexagonal pyramidal #s. */
/* see https://oeis.org/A002412 */
greenGrocer=0 4 16 40 80 140 224 336 480 660 880 1144 1456 1820 2240 2720 3264 3876,
4560
/* define twenty-three Bernoulli numerator numbers*/
/* source ?? quotes needed because of negative #s.*/
bernN='1 -1 1 0 -1 0 1 0 -1 0 5 0 -691 0 7 0 -3617 0 43867 0 -174611 0'
/* also called the Reduced Totient function, */
/* and is also called Carmichael lambda, */
/* or the LAMBDA function */
/* see https://en.wikipedia.org/wiki/Carmichael_function */
psi=1 1 2 2 4 2 6 2 6 4 10 2 12 6 4 4 16 6 18 4 6 10 22 2 20 12 18 6 28 4 30 8 10 16
list=gHopper greenGrocer bernN psi /*combine the four lists into one list.*/
Call show 'before sort',list /*display the list before sorting. */
Say copies('¦', 75) /*show long separator line before sort.*/
Call show ' after sort',beadSort(list) /*display the list after sorting. */
Exit /*stick a fork in it, we're all done. */
/*----------------------------------------------------------------------------------*/
beadSort: Procedure
Parse Arg list 1 low . 1 high . /* List to be sorted and first value */
occurences.=0 /* count stem occurences */
Do Until list=='' /* loop through the list */
Parse Var list bead list /* take an element */
bead= bead / 1 /* normalize the value */
occurences.bead=occurences.bead + 1 /* bump occurences */
low= min(low, bead) /* track lowest */
high=max(high,bead) /* and highest number */
End
sorted='' /* now, collect the beads */
Do v=low To high
If occurences.v>0 Then
sorted=sorted copies(v' ', occurences.v)
End
Return sorted
/*----------------------------------------------------------------------------------*/
show:
Parse Arg txt,slist
n=words(slist)
w=length(n)
Do k=1 For n
Say right('element',30) right(k,w) txt':' right(word(slist,k),9)
End
Return
- output when using the default input:
(Shown at three-quarter size.)
element 1 before sort: 1 element 2 before sort: 4 element 3 before sort: 10 element 4 before sort: 12 element 5 before sort: 22 element 6 before sort: 26 element 7 before sort: 30 element 8 before sort: 46 element 9 before sort: 54 element 10 before sort: 62 element 11 before sort: 66 element 12 before sort: 78 element 13 before sort: 94 element 14 before sort: 110 element 15 before sort: 126 element 16 before sort: 134 element 17 before sort: 138 element 18 before sort: 158 element 19 before sort: 162 element 20 before sort: 186 element 21 before sort: 190 element 22 before sort: 222 element 23 before sort: 254 element 24 before sort: 270 element 25 before sort: 0 element 26 before sort: 4 element 27 before sort: 16 element 28 before sort: 40 element 29 before sort: 80 element 30 before sort: 140 element 31 before sort: 224 element 32 before sort: 336 element 33 before sort: 480 element 34 before sort: 660 element 35 before sort: 880 element 36 before sort: 1144 element 37 before sort: 1456 element 38 before sort: 1820 element 39 before sort: 2240 element 40 before sort: 2720 element 41 before sort: 3264 element 42 before sort: 3876 element 43 before sort: 4560 element 44 before sort: 1 element 45 before sort: -1 element 46 before sort: 1 element 47 before sort: 0 element 48 before sort: -1 element 49 before sort: 0 element 50 before sort: 1 element 51 before sort: 0 element 52 before sort: -1 element 53 before sort: 0 element 54 before sort: 5 element 55 before sort: 0 element 56 before sort: -691 element 57 before sort: 0 element 58 before sort: 7 element 59 before sort: 0 element 60 before sort: -3617 element 61 before sort: 0 element 62 before sort: 43867 element 63 before sort: 0 element 64 before sort: -174611 element 65 before sort: 0 element 66 before sort: 1 element 67 before sort: 1 element 68 before sort: 2 element 69 before sort: 2 element 70 before sort: 4 element 71 before sort: 2 element 72 before sort: 6 element 73 before sort: 2 element 74 before sort: 6 element 75 before sort: 4 element 76 before sort: 10 element 77 before sort: 2 element 78 before sort: 12 element 79 before sort: 6 element 80 before sort: 4 element 81 before sort: 4 element 82 before sort: 16 element 83 before sort: 6 element 84 before sort: 18 element 85 before sort: 4 element 86 before sort: 6 element 87 before sort: 10 element 88 before sort: 22 element 89 before sort: 2 element 90 before sort: 20 element 91 before sort: 12 element 92 before sort: 18 element 93 before sort: 6 element 94 before sort: 28 element 95 before sort: 4 element 96 before sort: 30 element 97 before sort: 8 element 98 before sort: 10 element 99 before sort: 16 ░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░ element 1 after sort: -174611 element 2 after sort: -3617 element 3 after sort: -691 element 4 after sort: -1 element 5 after sort: -1 element 6 after sort: -1 element 7 after sort: 0 element 8 after sort: 0 element 9 after sort: 0 element 10 after sort: 0 element 11 after sort: 0 element 12 after sort: 0 element 13 after sort: 0 element 14 after sort: 0 element 15 after sort: 0 element 16 after sort: 0 element 17 after sort: 0 element 18 after sort: 1 element 19 after sort: 1 element 20 after sort: 1 element 21 after sort: 1 element 22 after sort: 1 element 23 after sort: 1 element 24 after sort: 2 element 25 after sort: 2 element 26 after sort: 2 element 27 after sort: 2 element 28 after sort: 2 element 29 after sort: 2 element 30 after sort: 4 element 31 after sort: 4 element 32 after sort: 4 element 33 after sort: 4 element 34 after sort: 4 element 35 after sort: 4 element 36 after sort: 4 element 37 after sort: 4 element 38 after sort: 5 element 39 after sort: 6 element 40 after sort: 6 element 41 after sort: 6 element 42 after sort: 6 element 43 after sort: 6 element 44 after sort: 6 element 45 after sort: 7 element 46 after sort: 8 element 47 after sort: 10 element 48 after sort: 10 element 49 after sort: 10 element 50 after sort: 10 element 51 after sort: 12 element 52 after sort: 12 element 53 after sort: 12 element 54 after sort: 16 element 55 after sort: 16 element 56 after sort: 16 element 57 after sort: 18 element 58 after sort: 18 element 59 after sort: 20 element 60 after sort: 22 element 61 after sort: 22 element 62 after sort: 26 element 63 after sort: 28 element 64 after sort: 30 element 65 after sort: 30 element 66 after sort: 40 element 67 after sort: 46 element 68 after sort: 54 element 69 after sort: 62 element 70 after sort: 66 element 71 after sort: 78 element 72 after sort: 80 element 73 after sort: 94 element 74 after sort: 110 element 75 after sort: 126 element 76 after sort: 134 element 77 after sort: 138 element 78 after sort: 140 element 79 after sort: 158 element 80 after sort: 162 element 81 after sort: 186 element 82 after sort: 190 element 83 after sort: 222 element 84 after sort: 224 element 85 after sort: 254 element 86 after sort: 270 element 87 after sort: 336 element 88 after sort: 480 element 89 after sort: 660 element 90 after sort: 880 element 91 after sort: 1144 element 92 after sort: 1456 element 93 after sort: 1820 element 94 after sort: 2240 element 95 after sort: 2720 element 96 after sort: 3264 element 97 after sort: 3876 element 98 after sort: 4560 element 99 after sort: 43867
Ruby
class Array
def beadsort
map {|e| [1] * e}.columns.columns.map(&:length)
end
def columns
y = length
x = map(&:length).max
Array.new(x) do |row|
Array.new(y) { |column| self[column][row] }.compact # Remove nils.
end
end
end
# Demonstration code:
p [5,3,1,7,4,1,1].beadsort
- Output:
[7, 5, 4, 3, 1, 1, 1]
Seed7
$ include "seed7_05.s7i";
const proc: beadSort (inout array integer: a) is func
local
var integer: max is 0;
var integer: sum is 0;
var array bitset: beads is 0 times {};
var integer: i is 0;
var integer: j is 0;
begin
beads := length(a) times {};
for i range 1 to length(a) do
if a[i] > max then
max := a[i];
end if;
beads[i] := {1 .. a[i]};
end for;
for j range 1 to max do
sum := 0;
for i range 1 to length(a) do
sum +:= ord(j in beads[i]);
end for;
for i range length(a) downto length(a) - sum + 1 do
a[i] := j;
end for;
end for;
end func;
const proc: main is func
local
var array integer: a is [] (5, 3, 1, 7, 4, 1, 1, 20);
var integer: n is 0;
begin
beadSort(a);
for n range a do
write(n <& " ");
end for;
writeln;
end func;
- Output:
1 1 1 3 4 5 7 20
Sidef
func beadsort(arr) {
var rows = []
var columns = []
for datum in arr {
for column in ^datum {
++(columns[column] := 0)
++(rows[columns[column] - 1] := 0)
}
}
rows.reverse
}
say beadsort([5,3,1,7,4,1,1])
- Output:
[1, 1, 1, 3, 4, 5, 7]
Standard ML
fun columns l =
case List.filter (not o null) l of
[] => []
| l => map hd l :: columns (map tl l)
fun replicate (n, x) = List.tabulate (n, fn _ => x)
fun bead_sort l =
map length (columns (columns (map (fn e => replicate (e, 1)) l)))
usage
- bead_sort [5,3,1,7,4,1,1]; val it = [7,5,4,3,1,1,1] : int list
Tcl
package require Tcl 8.5
proc beadsort numList {
# Special case: empty list is empty when sorted.
if {![llength $numList]} return
# Set up the abacus...
foreach n $numList {
for {set i 0} {$i<$n} {incr i} {
dict incr vals $i
}
}
# Make the beads fall...
foreach n [dict values $vals] {
for {set i 0} {$i<$n} {incr i} {
dict incr result $i
}
}
# And the result is...
dict values $result
}
# Demonstration code
puts [beadsort {5 3 1 7 4 1 1}]
- Output:
7 5 4 3 1 1 1
VBA
Option Base 1
Private Function sq_add(arr As Variant, x As Double) As Variant
Dim res() As Variant
ReDim res(UBound(arr))
For i = 1 To UBound(arr)
res(i) = arr(i) + x
Next i
sq_add = res
End Function
Private Function beadsort(ByVal a As Variant) As Variant
Dim poles() As Variant
ReDim poles(WorksheetFunction.Max(a))
For i = 1 To UBound(a)
For j = 1 To a(i)
poles(j) = poles(j) + 1
Next j
Next i
For j = 1 To UBound(a)
a(j) = 0
Next j
For i = 1 To UBound(poles)
For j = 1 To poles(i)
a(j) = a(j) + 1
Next j
Next i
beadsort = a
End Function
Public Sub main()
Debug.Print Join(beadsort([{5, 3, 1, 7, 4, 1, 1, 20}]), ", ")
End Sub
- Output:
20, 7, 5, 4, 3, 1, 1, 1
Wren
A translation of the Python code in the Wikipedia article. Only works properly for lists of non-negative integers.
var beadSort = Fn.new { |a|
var res = []
var max = a.reduce { |acc, i| (i > acc) ? i : acc }
var trans = [0] * max
for (i in a) {
for (n in 0...i) trans[n] = trans[n] + 1
}
for (i in a) {
res.add(trans.count { |n| n > 0 })
for (n in 0...trans.count) trans[n] = trans[n] - 1
}
return res[-1..0] // return in ascending order
}
var array = [ [4, 65, 2, 31, 0, 99, 2, 83, 782, 1], [7, 5, 2, 6, 1, 4, 2, 6, 3] ]
for (a in array) {
System.print("Before: %(a)")
a = beadSort.call(a)
System.print("After : %(a)")
System.print()
}
- Output:
Before: [4, 65, 2, 31, 0, 99, 2, 83, 782, 1] After : [0, 1, 2, 2, 4, 31, 65, 83, 99, 782] Before: [7, 5, 2, 6, 1, 4, 2, 6, 3] After : [1, 2, 2, 3, 4, 5, 6, 6, 7]
XPL0
include c:\cxpl\codes;
proc BeadSort(Array, Length); \Sort Array into increasing order
int Array, Length; \Array contents range 0..31; number of items
int Row, I, J, T, C;
[Row:= Reserve(Length*4); \each Row has room for 32 beads
for I:= 0 to Length-1 do \each Row gets Array(I) number of beads
Row(I):= ~-1<<Array(I); \(beware for 80186..Pentium <<32 doesn't shift)
for J:= 1 to Length-1 do
for I:= Length-1 downto J do
[T:= Row(I-1) & ~Row(I); \up to 31 beads fall in a single pass
Row(I-1):= Row(I-1) | T; \(|=xor, !=or)
Row(I):= Row(I) | T;
];
for I:= 0 to Length-1 do \count beads in each Row
[C:= 0; T:= Row(I);
while T do
[if T&1 then C:= C+1; T:= T>>1];
Array(I):= C; \count provides sorted order
];
];
int A, I;
[A:= [3, 1, 4, 1, 25, 9, 2, 6, 5, 0];
BeadSort(A, 10);
for I:= 0 to 10-1 do [IntOut(0, A(I)); ChOut(0, ^ )];
]
- Output:
0 1 1 2 3 4 5 6 9 25
zkl
fcn columns(m){ // m is list of lists of zeros/beads, # beads is n, eg (0,0,0)==3
m
.apply("len") // (0,0,0)-->3
.reduce("max") // largest bead stack
.walker() // [0..max]
.apply('wrap(i){ m.filter('wrap(s){ s.len() > i }).len().pump(List,0) });
}
fcn beadSort(data){
data.apply("pump",List,0):columns(_):columns(_).apply("len");
}
T(5,3,1,7,4,1,1):beadSort(_).println();
T(4,3,3,2,1):beadSort(_).println();
- Output:
L(7,5,4,3,1,1,1) L(4,3,3,2,1)
- Programming Tasks
- Sorting Algorithms
- Sorting
- 11l
- 360 Assembly
- AArch64 Assembly
- ARM Assembly
- Arturo
- AutoHotkey
- BCPL
- C
- C++
- Clojure
- COBOL
- Common Lisp
- D
- Delphi
- Eiffel
- Elixir
- Erlang
- F Sharp
- Factor
- Fortran
- FreeBASIC
- Go
- Groovy
- Haskell
- Icon
- Unicon
- J
- Java
- Jq
- Julia
- Kotlin
- Lua
- Mathematica
- Wolfram Language
- NetRexx
- Nim
- OCaml
- Octave
- OoRexx
- OpenEdge/Progress
- PARI/GP
- Pascal
- Perl
- Phix
- PHP
- PicoLisp
- PL/I
- PowerShell
- PureBasic
- Python
- QB64
- Racket
- Raku
- REXX
- Ruby
- Seed7
- Sidef
- Standard ML
- Tcl
- VBA
- Wren
- XPL0
- Zkl
- GUISS/Omit