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

Data update

Browse source
This commit is contained in:
Ingy döt Net 2024-11-04 20:28:54 -08:00
parent 52a6ef48dd
commit 157b70a810
604 changed files with 14253 additions and 2100 deletions
Download patch file Download diff file Expand all files Collapse all files

5
Task/100-doors/00-TASK.txt
View file

@ -20,3 +20,8 @@ Opening only those doors is an   [[task feature::Rosetta Code:optimization|
however, as should be obvious, this defeats the intent of comparing implementations across programming languages.
<br><br>
;Why doesn't syntax highlighting work on this page ?:
Currently, there is a limit on how many &lt;syntaxhighlight&gt; tags can appear on a page, so only the first few languages get highlighting, the rest are shown in monochrome.<br/>
You could try "manual highlighting", possibly using one of the highlighters on [[Syntax highlighting using Mediawiki formatting]] or something similar.

1
Task/100-doors/Plain-English/100-doors.plain
View file

@ -6,6 +6,7 @@ Clear the door's flag.
Append the door to the doors.
Repeat.
A flag thing is a thing with a flag.
A door is a flag thing.
To go through some doors given a number and some passes:

25
Task/100-doors/YAMLScript/100-doors.ys
View file

@ -1,17 +1,14 @@
!yamlscript/v0
defn main():
say: |-
Open doors after 100 passes:
$(open-doors().join(', '))
defn open-doors():
? for [d n] map(vector doors() range().drop(1))
:when d
: n
defn doors():
reduce:
fn(doors idx): doors.assoc(idx true)
into []: repeat(100 false)
map \(sqr(_).--): 1 .. 10
open =:
reduce _ vec([true] * 100) (1 .. 100):
fn(doors i):
loop j i, doors doors:
if j < 100:
recur (j + i).++:
update-in doors [j]: \(doors.$j.!)
else: doors
say: -"Open doors after 100 passes:\ " +
(1 .. 100).map(\(_.--:open && _))
.filter(a).join(', ')

288
Task/15-puzzle-solver/FreeBASIC/15-puzzle-solver.basic Normal file
View file

@ -0,0 +1,288 @@
Randomize Timer
Dim Shared As Integer Nr(15) = {3, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3}
Dim Shared As Integer Nc(15) = {3, 0, 1, 2, 3, 0, 1, 2, 3, 0, 1, 2, 3, 0, 1, 2}
Dim Shared As Integer n, nn
Dim Shared As Integer N0(99), N3(100), N4(99)
Dim Shared As Ulongint N2(99)
Enum
Ki = 1
Kg = 8
Ke = 2
Kl = 4
End Enum
Dim Shared As Integer l = 108, r = 114, u = 117, d = 100
Declare Function fY() As Boolean
Declare Function fZ(w As Integer) As Boolean
Declare Function fN() As Boolean
Sub fI()
Dim As Integer g = (11 - N0(n)) * 4
Dim As Ulongint a = (N2(n) And (15ULL Shl g))
N0(n + 1) = N0(n) + 4
N2(n + 1) = N2(n) - a + (a Shl 16)
N3(n + 1) = d
N4(n + 1) = N4(n)
If Not(Nr((a Shr g)) <= N0(n)\4) Then N4(n + 1) += 1
n += 1
End Sub
Sub fG()
Dim As Integer g = (19 - N0(n)) * 4
Dim As Ulongint a = (N2(n) And (15ULL Shl g))
N0(n + 1) = N0(n) - 4
N2(n + 1) = N2(n) - a + (a Shr 16)
N3(n + 1) = u
N4(n + 1) = N4(n)
If Not(Nr((a Shr g)) >= N0(n)\4) Then N4(n + 1) += 1
n += 1
End Sub
Sub fE()
Dim As Integer g = (14 - N0(n)) * 4
Dim As Ulongint a = (N2(n) And (15ULL Shl g))
N0(n + 1) = N0(n) + 1
N2(n + 1) = N2(n) - a + (a Shl 4)
N3(n + 1) = r
N4(n + 1) = N4(n)
If Not(Nc((a Shr g)) <= (N0(n) Mod 4)) Then N4(n + 1) += 1
n += 1
End Sub
Sub fL()
Dim As Integer g = (16 - N0(n)) * 4
Dim As Ulongint a = (N2(n) And (15ULL Shl g))
N0(n + 1) = N0(n) - 1
N2(n + 1) = N2(n) - a + (a Shr 4)
N3(n + 1) = l
N4(n + 1) = N4(n)
If Not(Nc((a Shr g)) >= (N0(n) Mod 4)) Then N4(n + 1) += 1
n += 1
End Sub
Function fY() As Boolean
If N2(n) = &h123456789abcdef0ULL Then Return True
If N4(n) <= nn Then Return fN()
Return False
End Function
Function fZ(w As Integer) As Boolean
If (w And Ki) > 0 Then
fI()
If fY() Then Return True
n -= 1
End If
If (w And Kg) > 0 Then
fG()
If fY() Then Return True
n -= 1
End If
If (w And Ke) > 0 Then
fE()
If fY() Then Return True
n -= 1
End If
If (w And Kl) > 0 Then
fL()
If fY() Then Return True
n -= 1
End If
Return False
End Function
Function fN() As Boolean
Select Case N0(n)
Case 0
Select Case N3(n)
Case l: Return fZ(Ki)
Case u: Return fZ(Ke)
Case Else: Return fZ(Ki Or Ke)
End Select
Case 3
Select Case N3(n)
Case r: Return fZ(Ki)
Case u: Return fZ(Kl)
Case Else: Return fZ(Ki Or Kl)
End Select
Case 1, 2
Select Case N3(n)
Case l: Return fZ(Ki Or Kl)
Case r: Return fZ(Ki Or Ke)
Case u: Return fZ(Ke Or Kl)
Case Else: Return fZ(Kl Or Ke Or Ki)
End Select
Case 12
Select Case N3(n)
Case l: Return fZ(Kg)
Case d: Return fZ(Ke)
Case Else: Return fZ(Ke Or Kg)
End Select
Case 15
Select Case N3(n)
Case r: Return fZ(Kg)
Case d: Return fZ(Kl)
Case Else: Return fZ(Kg Or Kl)
End Select
Case 13, 14
Select Case N3(n)
Case l: Return fZ(Kg Or Kl)
Case r: Return fZ(Ke Or Kg)
Case d: Return fZ(Ke Or Kl)
Case Else: Return fZ(Kg Or Ke Or Kl)
End Select
Case 4, 8
Select Case N3(n)
Case l: Return fZ(Ki Or Kg)
Case u: Return fZ(Kg Or Ke)
Case d: Return fZ(Ki Or Ke)
Case Else: Return fZ(Ki Or Kg Or Ke)
End Select
Case 7, 11
Select Case N3(n)
Case d: Return fZ(Ki Or Kl)
Case u: Return fZ(Kg Or Kl)
Case r: Return fZ(Ki Or Kg)
Case Else: Return fZ(Ki Or Kg Or Kl)
End Select
Case Else
Select Case N3(n)
Case d: Return fZ(Ki Or Ke Or Kl)
Case l: Return fZ(Ki Or Kg Or Kl)
Case r: Return fZ(Ki Or Kg Or Ke)
Case u: Return fZ(Kg Or Ke Or Kl)
Case Else: Return fZ(Ki Or Kg Or Ke Or Kl)
End Select
End Select
End Function
Sub solve()
If fN() Then
Exit Sub
Else
n = 0
nn += 1
solve()
End If
End Sub
Function createPuzzle(Byval j As Integer) As Ulongint
Dim As Ulongint q = &h123456789abcdef0ULL
Dim As String h = Hex(q, 16)
Dim As Integer z, d, r, u = 0
While j > 0 ' number of moves to do
Do
d = Int(Rnd * 4) + 1
Loop While d = u
u = -d
r = Int(Rnd * 3) + 1
While r > 0
z = Instr(h, "0")
Select Case d
Case 1 ' -1
If (z Mod 4) <> 1 Then
Mid(h, z, 1) = Mid(h, z - 1, 1)
Mid(h, z - 1, 1) = "0"
j -= 1
End If
Case 2 ' +1
If (z Mod 4) <> 0 Then
Mid(h, z, 1) = Mid(h, z + 1, 1)
Mid(h, z + 1, 1) = "0"
j -= 1
End If
Case 3 ' -4
If z >= 5 Then
Mid(h, z, 1) = Mid(h, z - 4, 1)
Mid(h, z - 4, 1) = "0"
j -= 1
End If
Case 4 ' +4
If z <= 12 Then
Mid(h, z, 1) = Mid(h, z + 4, 1)
Mid(h, z + 4, 1) = "0"
j -= 1
End If
End Select
r -= 1
Wend
Wend
Return Valulng("&h" + h)
End Function
Sub ShowConfiguration(Byval h As String, i As Integer)
Dim As Integer r, c
Dim x As String
Color 14
For r = 1 To 4
For c = 1 To 4
x = Mid(h, r * 4 - 4 + c, 1)
If x = "0" Then x = " "
Locate r + i, c + c - 1: Print x;
Next
Next
Color 7
End Sub
Sub shoWMoves(Byval h As String, Byval s As String, Byval m As Integer, Byval p As Integer)
Dim As Integer j, z, d
ShowConfiguration(h, 12)
For j = 1 To m
d = Asc(Mid(s, j, 1))
z = Instr(h, "0")
Select Case d
Case l
If (z Mod 4) <> 1 Then
Mid(h, z, 1) = Mid(h, z - 1, 1)
Mid(h, z - 1, 1) = "0"
End If
Case r
If (z Mod 4) <> 0 Then
Mid(h, z, 1) = Mid(h, z + 1, 1)
Mid(h, z + 1, 1) = "0"
End If
Case u
If z >= 5 Then
Mid(h, z, 1) = Mid(h, z - 4, 1)
Mid(h, z - 4, 1) = "0"
End If
Case d
If z <= 12 Then
Mid(h, z, 1) = Mid(h, z + 4, 1)
Mid(h, z + 4, 1) = "0"
End If
End Select
ShowConfiguration(h, 12)
Sleep p
Next
Print
End Sub
Sub fifteenSolver(Byval g As Ulongint, Byval p As Integer)
Dim As String h, s
Dim As Integer j
Dim As Double t0 = Timer
n = 0
nn = 0
h = Hex(g, 16)
Cls
Print "Puzzle: "; Lcase(h)
ShowConfiguration(h, 2)
Print Chr(10)
N0(0) = Instr(h, "0") - 1
N2(0) = g
solve()
Print Using "Solution found in & moves: "; n;
For j = 1 To n
s &= Chr(N3(j))
Next
Print s
Print Using !"\nTook ###.######## seconds on i5 @ 3.20 GHz"; Timer - t0
If p Then showMoves(h, s, n, p)
End Sub
fifteenSolver(&hfe169b4c0a73d852ULL, 1000)
Sleep

165
Task/15-puzzle-solver/FutureBasic/15-puzzle-solver.basic Normal file
View file

@ -0,0 +1,165 @@
// 15 Puzzle Solver
//https://rosettacode.org/wiki/15_puzzle_solver
// Requires FutureBasic 7.0.30 or later
begin globals
int Nr(15), Nc(15), n, un, N0(99), N3(99), N4(99)
UInt64 N2(99)
end globals
def fn fY as BOOL
void def fn fI
void def fn fG
void def fn fE
void def fn fL
local fn fN1 as BOOL
if ( N3(n) != _"u" && N0(n) / 4 < 3 )
fn fI
n++
if ( fn fY ) then return YES
n--
end if
if ( N3(n) != _"d" && N0(n) / 4 > 0 )
fn fG
n++
if ( fn fY ) then return YES
n--
end if
if ( N3(n) != _"l" && N0(n) % 4 < 3 )
fn fE
n++
if ( fn fY ) then return YES
n--
end if
if ( N3(n) != _"r" && N0(n) %4 > 0 )
fn fL
n++
if ( fn fY ) then return YES
n--
end if
end fn = NO
void local fn fI
int g = ( 11 - N0(n)) * 4
UInt64 a = N2(n) & ((UInt64)15 << g)
N0(n + 1) = N0(n) + 4
N2(n + 1) = N2(n) - a + (a << 16)
N3(n + 1) = _"d"
if ( Nr(a >> g) <= N0(n) / 4 )
N4(n + 1) = N4(n)
else
N4(n + 1) = N4(n) + 1
end if
end fn
void local fn fG
int g = (19 - N0(n)) * 4
UInt64 a = N2(n) & ((UInt64)15 << g)
N0(n + 1) = N0(n) - 4
N2(n + 1) = N2(n) - a + (a >> 16)
N3(n + 1) = _"u"
if ( Nr(a >> g) >= N0(n) / 4 )
N4(n + 1) = N4(n)
else
N4(n + 1) = N4(n) + 1
end if
end fn
void local fn fE
int g = (14 - N0(n)) * 4
UInt64 a = N2(n) & ((UInt64)15 << g)
N0(n + 1) = N0(n) + 1
N2(n + 1) = N2(n) - a + (a << 4)
N3(n + 1) = _"r"
if ( Nc(a >> g) <= N0(n) % 4 )
N4(n + 1) = N4(n)
else
N4(n + 1) = N4(n) + 1
end if
end fn
void local fn fL
int g = (16 - N0(n)) * 4
UInt64 a = N2(n) & ((UInt64)15 << g)
N0(n + 1) = N0(n) - 1
N2(n + 1) = N2(n) - a + (a >> 4)
N3(n + 1) = _"l"
if ( Nc(a >> g) >= N0(n) % 4 )
N4(n + 1) = N4(n)
else
N4(n + 1) = N4(n) + 1
end if
end fn
local fn fY as BOOL
if ( N4(n) < un ) then return fn fN1
if ( N2(n) == 0x123456789abcdef0 )
printf @"Solution found in %d moves:",n
for int g = 1 to n
printf @"%c\b",N3(g)
next
print
return YES
end if
if ( N4(n) == un ) then return fn fN1
end fn = NO
void local fn Solve( initN as int, initG as UInt64 )
int tempNr(15) = {3,0,0,0,0,1,1,1,1,2,2,2,2,3,3,3}
int tempNc(15) = {3,0,1,2,3,0,1,2,3,0,1,2,3,0,1,2}
fn memcpy(@Nr(0),@tempNr(0),sizeof(int)*16)
fn memcpy(@Nc(0),@tempNc(0),sizeof(int)*16)
n = 0
un = 0
N0(0) = initN
N2(0) = initG
while ( !fn fY )
un++
wend
end fn
window 1, @"15 Puzzle Solver"
windowcenter(1)
WindowSetBackgroundColor(1,fn ColorBlack)
text ,14,fn colorWhite
Print "Puzzle: "; "fe169b4c0a73d852"
text ,14,fn colorYellow
print
print @"15 14 1 6"
print @" 9 11 4 12"
print @" 0 10 7 3"
print @"13 8 5 2"
print
text ,14,fn colorWhite
CFStringRef ComputerChip = unix @"sysctl -n machdep.cpu.brand_string"
CFTimeInterval t : t = fn CACurrentMediaTime
fn Solve( 8, 0xfe169b4c0a73d852 )
CFTimeInterval CurrentTime = fn CACurrentMediaTime-t
print
text ,14,fn colorYellow
print
print @" 1 2 3 4"
print @" 5 6 7 8"
print @" 9 10 11 12"
print @"13 14 15 0"
print
text ,14,fn colorWhite
print : printf @"Compute time: %.3f seconds",(CurrentTime)
print ComputerChip
HandleEvents

10
Task/24-game/ALGOL-68/24-game.alg
View file

@ -40,7 +40,7 @@ BEGIN # play the 24 game - present the user with 4 digits and invite them to #
error( "Unexpected """ + curr ch + """" );
0
FI # factor # ;
PROC term = REAL:
PROC expr term = REAL:
BEGIN
REAL result := factor;
WHILE curr ch = "*" OR curr ch = "/" DO
@ -49,14 +49,14 @@ BEGIN # play the 24 game - present the user with 4 digits and invite them to #
IF op = "*" THEN result *:= factor ELSE result /:= factor FI
OD;
result
END # term # ;
END # expr term # ;
PROC expression = REAL:
BEGIN
REAL result := term;
REAL result := expr term;
WHILE curr ch = "+" OR curr ch = "-" DO
CHAR op = curr ch;
next ch;
IF op = "+" THEN result +:= term ELSE result -:= term FI
IF op = "+" THEN result +:= expr term ELSE result -:= expr term FI
OD;
result
END # expression # ;
@ -80,7 +80,7 @@ BEGIN # play the 24 game - present the user with 4 digits and invite them to #
puzzle digits[ i ] := 0
OD;
print( ( "Enter an expression using these digits:" ) );
FOR i TO 4 DO # pick 4 random digits #
TO 4 DO # pick 4 random digits #
INT digit := 1 + ENTIER ( next random * 9 );
IF digit > 9 THEN digit := 9 FI;
puzzle digits[ digit ] +:= 1;

1
Task/99-bottles-of-beer/YAMLScript/99-bottles-of-beer-1.ys
View file

@ -1,7 +1,6 @@
!yamlscript/v0
defn main(number=99):
:: Print the verses to "99 Bottles of Beer"
each num (number .. 1):
say: |
$bottles(num) of beer on the wall,

47
Task/ABC-problem/ALGOL-68/abc-problem.alg
View file

@ -1,21 +1,14 @@
# ABC problem: #
# determine whether we can spell words with a set of blocks #
# construct the list of blocks #
[][]STRING blocks = ( ( "B", "O" ), ( "X", "K" ), ( "D", "Q" ), ( "C", "P" )
, ( "N", "A" ), ( "G", "T" ), ( "R", "E" ), ( "T", "G" )
, ( "Q", "D" ), ( "F", "S" ), ( "J", "W" ), ( "H", "U" )
, ( "V", "I" ), ( "A", "N" ), ( "O", "B" ), ( "E", "R" )
, ( "F", "S" ), ( "L", "Y" ), ( "P", "C" ), ( "Z", "M" )
);
# Returns TRUE if we can spell the word using the blocks, FALSE otherwise #
# Returns TRUE for an empty string #
PROC can spell = ( STRING word, [][]STRING blocks )BOOL:
PROC can spell = ( STRING word, [][]STRING block set )BOOL:
BEGIN
# construct a set of flags to indicate whether the blocks are used #
# or not #
[ 1 LWB blocks : 1 UPB blocks ]BOOL used;
[ 1 LWB block set : 1 UPB block set ]BOOL used;
FOR block pos FROM LWB used TO UPB used
DO
used[ block pos ] := FALSE
@ -34,11 +27,11 @@ PROC can spell = ( STRING word, [][]STRING blocks )BOOL:
# look through the unused blocks for the current letter #
BOOL found := FALSE;
FOR block pos FROM 1 LWB blocks TO 1 UPB blocks
FOR block pos FROM 1 LWB block set TO 1 UPB block set
WHILE NOT found
DO
IF ( c = blocks[ block pos ][ 1 ][ 1 ]
OR c = blocks[ block pos ][ 2 ][ 1 ]
IF ( c = block set[ block pos ][ 1 ][ 1 ]
OR c = block set[ block pos ][ 2 ][ 1 ]
)
AND NOT used[ block pos ]
THEN
@ -56,25 +49,33 @@ PROC can spell = ( STRING word, [][]STRING blocks )BOOL:
END; # can spell #
main: (
# main # (
[][]STRING abc blocks # construct the list of blocks #
= ( ( "B", "O" ), ( "X", "K" ), ( "D", "Q" ), ( "C", "P" )
, ( "N", "A" ), ( "G", "T" ), ( "R", "E" ), ( "T", "G" )
, ( "Q", "D" ), ( "F", "S" ), ( "J", "W" ), ( "H", "U" )
, ( "V", "I" ), ( "A", "N" ), ( "O", "B" ), ( "E", "R" )
, ( "F", "S" ), ( "L", "Y" ), ( "P", "C" ), ( "Z", "M" )
);
# test the can spell procedure #
PROC test can spell = ( STRING word, [][]STRING blocks )VOID:
PROC test can spell = ( STRING word, [][]STRING block set )VOID:
write( ( ( "can spell: """
+ word
+ """ -> "
+ IF can spell( word, blocks ) THEN "yes" ELSE "no" FI
+ IF can spell( word, block set ) THEN "yes" ELSE "no" FI
)
, newline
)
);
test can spell( "A", blocks );
test can spell( "BaRK", blocks );
test can spell( "BOOK", blocks );
test can spell( "TREAT", blocks );
test can spell( "COMMON", blocks );
test can spell( "SQUAD", blocks );
test can spell( "CONFUSE", blocks )
test can spell( "A", abc blocks );
test can spell( "BaRK", abc blocks );
test can spell( "BOOK", abc blocks );
test can spell( "TREAT", abc blocks );
test can spell( "COMMON", abc blocks );
test can spell( "SQUAD", abc blocks );
test can spell( "CONFUSE", abc blocks )
)

78
Task/AKS-test-for-primes/Phix/aks-test-for-primes-1.phix Normal file
View file

@ -0,0 +1,78 @@
-- demo/rosetta/AKSprimes.exw
-- Does not work for primes above 67 (56 on 32bit), which is actually beyond the original task anyway.
-- Translated from the C version (with all out-by-1 stuff now eradicated).
with javascript_semantics
constant limit = iff(machine_bits()=32?56:67)
sequence c = repeat(0,limit+1)
procedure coef(integer n)
c[n+1] = 1
for i=n to 2 by -1 do
c[i] += c[i-1]
end for
end procedure
function is_aks_prime(integer n)
coef(n)
for i=2 to n-1 do
if remainder(c[i],n)!=0 then
return false
end if
end for
return true
end function
procedure show(integer n)
for i=n+1 to 1 by -1 do
object ci = c[i]
if ci=1 then
if remainder(n-i+1,2)=0 then
if i=1 then
if n=0 then
ci = "1"
else
ci = "+1"
end if
else
ci = ""
end if
else
ci = "-1"
end if
else
if remainder(n-i+1,2)=0 then
ci = sprintf("+%d",ci)
else
ci = sprintf("-%d",ci)
end if
end if
if i=1 then -- ie ^0
printf(1,"%s",{ci})
elsif i=2 then -- ie ^1
printf(1,"%sx",{ci})
else
printf(1,"%sx^%d",{ci,i-1})
end if
end for
end procedure
procedure main()
for n=0 to 9 do
coef(n);
printf(1,"(x-1)^%d = ", n);
show(n);
puts(1,'\n');
end for
printf(1,"\nprimes (<=%d):",limit);
-- coef(1); -- (needed to reset c, if we want to avoid saying 1 is prime...)
c[2] = 1 -- (this manages "", which is all that call did anyway...)
for n=2 to limit do
if is_aks_prime(n) then
printf(1," %d", n);
end if
end for
puts(1,'\n');
wait_key()
end procedure
main()

27
Task/AKS-test-for-primes/Phix/aks-test-for-primes-2.phix Normal file
View file

@ -0,0 +1,27 @@
include mpfr.e
mpz z = mpz_init()
atom t0 = time(), t1 = t0+1
sequence p = {}
integer maxn = 0
for n=2 to 10000 do -- (more than we can manage in 10s)
bool nprime = true
for k=1 to n-1 do
mpz_bin_uiui(z,n,k)
if not mpz_divisible_ui_p(z,n) then
nprime = false
exit
end if
end for
if nprime then
p &= n
end if
maxn = n
if time()>t1 then
if time()>t0+10 then progress("") exit end if
progress("checking %d",{n})
t1 = time()+1
end if
end for
sequence q = get_primes_le(maxn)
printf(1,"%d primes < %d found, correctly:%t, in %s\n",{length(p),maxn,p=q,elapsed(time()-t0)})
wait_key()

24
Task/AKS-test-for-primes/Phix/aks-test-for-primes-3.phix Normal file
View file

@ -0,0 +1,24 @@
atom t0 = time(), t1 = t0+1
sequence p = {}
integer maxn = 0
for n=2 to 10000 do -- (more than we can manage in 10s)
sequence r = {1}
for k=1 to n do
r &= 1
for l=k to 2 by -1 do
r[l] = remainder(r[l]+r[l-1],n)
end for
end for
if sum(r)=2 then -- ie {1,<==all 0s==>,1}
p &= n
end if
maxn = n
if time()>t1 then
if time()>t0+10 then progress("") exit end if
progress("checking %d",{n})
t1 = time()+1
end if
end for
sequence q = get_primes_le(maxn)
printf(1,"%d primes < %d found, correctly:%t, in %s\n",{length(p),maxn,p=q,elapsed(time()-t0)})
wait_key()

82
Task/AKS-test-for-primes/Phix/aks-test-for-primes.phix
View file

@ -1,82 +0,0 @@
-->
<span style="color: #000080;font-style:italic;">-- demo/rosetta/AKSprimes.exw
-- Does not work for primes above 53, which is actually beyond the original task anyway.
-- Translated from the C version, just about everything is (working) out-by-1, what fun.</span>
<span style="color: #004080;">sequence</span> <span style="color: #000000;">c</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: #000000;">100</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">procedure</span> <span style="color: #000000;">coef</span><span style="color: #0000FF;">(</span><span style="color: #004080;">integer</span> <span style="color: #000000;">n</span><span style="color: #0000FF;">)</span>
<span style="color: #000080;font-style:italic;">-- out-by-1, ie coef(1)==^0, coef(2)==^1, coef(3)==^2 etc.</span>
<span style="color: #000000;">c</span><span style="color: #0000FF;">[</span><span style="color: #000000;">n</span><span style="color: #0000FF;">]</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">1</span>
<span style="color: #008080;">for</span> <span style="color: #000000;">i</span><span style="color: #0000FF;">=</span><span style="color: #000000;">n</span><span style="color: #0000FF;">-</span><span style="color: #000000;">1</span> <span style="color: #008080;">to</span> <span style="color: #000000;">2</span> <span style="color: #008080;">by</span> <span style="color: #0000FF;">-</span><span style="color: #000000;">1</span> <span style="color: #008080;">do</span>
<span style="color: #000000;">c</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: #000000;">c</span><span style="color: #0000FF;">[</span><span style="color: #000000;">i</span><span style="color: #0000FF;">]+</span><span style="color: #000000;">c</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;">end</span> <span style="color: #008080;">procedure</span>
<span style="color: #008080;">function</span> <span style="color: #000000;">is_aks_prime</span><span style="color: #0000FF;">(</span><span style="color: #004080;">integer</span> <span style="color: #000000;">n</span><span style="color: #0000FF;">)</span>
<span style="color: #000000;">coef</span><span style="color: #0000FF;">(</span><span style="color: #000000;">n</span><span style="color: #0000FF;">+</span><span style="color: #000000;">1</span><span style="color: #0000FF;">);</span> <span style="color: #000080;font-style:italic;">-- (I said it was out-by-1)</span>
<span style="color: #008080;">for</span> <span style="color: #000000;">i</span><span style="color: #0000FF;">=</span><span style="color: #000000;">2</span> <span style="color: #008080;">to</span> <span style="color: #000000;">n</span><span style="color: #0000FF;">-</span><span style="color: #000000;">1</span> <span style="color: #008080;">do</span> <span style="color: #000080;font-style:italic;">-- (technically "to n" is more correct)</span>
<span style="color: #008080;">if</span> <span style="color: #7060A8;">remainder</span><span style="color: #0000FF;">(</span><span style="color: #000000;">c</span><span style="color: #0000FF;">[</span><span style="color: #000000;">i</span><span style="color: #0000FF;">],</span><span style="color: #000000;">n</span><span style="color: #0000FF;">)!=</span><span style="color: #000000;">0</span> <span style="color: #008080;">then</span>
<span style="color: #008080;">return</span> <span style="color: #000000;">0</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">for</span>
<span style="color: #008080;">return</span> <span style="color: #000000;">1</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>
<span style="color: #008080;">procedure</span> <span style="color: #000000;">show</span><span style="color: #0000FF;">(</span><span style="color: #004080;">integer</span> <span style="color: #000000;">n</span><span style="color: #0000FF;">)</span>
<span style="color: #000080;font-style:italic;">-- (As per coef, this is (working) out-by-1)</span>
<span style="color: #004080;">object</span> <span style="color: #000000;">ci</span>
<span style="color: #008080;">for</span> <span style="color: #000000;">i</span><span style="color: #0000FF;">=</span><span style="color: #000000;">n</span> <span style="color: #008080;">to</span> <span style="color: #000000;">1</span> <span style="color: #008080;">by</span> <span style="color: #0000FF;">-</span><span style="color: #000000;">1</span> <span style="color: #008080;">do</span>
<span style="color: #000000;">ci</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">c</span><span style="color: #0000FF;">[</span><span style="color: #000000;">i</span><span style="color: #0000FF;">]</span>
<span style="color: #008080;">if</span> <span style="color: #000000;">ci</span><span style="color: #0000FF;">=</span><span style="color: #000000;">1</span> <span style="color: #008080;">then</span>
<span style="color: #008080;">if</span> <span style="color: #7060A8;">remainder</span><span style="color: #0000FF;">(</span><span style="color: #000000;">n</span><span style="color: #0000FF;">-</span><span style="color: #000000;">i</span><span style="color: #0000FF;">,</span><span style="color: #000000;">2</span><span style="color: #0000FF;">)=</span><span style="color: #000000;">0</span> <span style="color: #008080;">then</span>
<span style="color: #008080;">if</span> <span style="color: #000000;">i</span><span style="color: #0000FF;">=</span><span style="color: #000000;">1</span> <span style="color: #008080;">then</span>
<span style="color: #008080;">if</span> <span style="color: #000000;">n</span><span style="color: #0000FF;">=</span><span style="color: #000000;">1</span> <span style="color: #008080;">then</span>
<span style="color: #000000;">ci</span> <span style="color: #0000FF;">=</span> <span style="color: #008000;">"1"</span>
<span style="color: #008080;">else</span>
<span style="color: #000000;">ci</span> <span style="color: #0000FF;">=</span> <span style="color: #008000;">"+1"</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">else</span>
<span style="color: #000000;">ci</span> <span style="color: #0000FF;">=</span> <span style="color: #008000;">""</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">else</span>
<span style="color: #000000;">ci</span> <span style="color: #0000FF;">=</span> <span style="color: #008000;">"-1"</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">else</span>
<span style="color: #008080;">if</span> <span style="color: #7060A8;">remainder</span><span style="color: #0000FF;">(</span><span style="color: #000000;">n</span><span style="color: #0000FF;">-</span><span style="color: #000000;">i</span><span style="color: #0000FF;">,</span><span style="color: #000000;">2</span><span style="color: #0000FF;">)=</span><span style="color: #000000;">0</span> <span style="color: #008080;">then</span>
<span style="color: #000000;">ci</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">sprintf</span><span style="color: #0000FF;">(</span><span style="color: #008000;">"+%d"</span><span style="color: #0000FF;">,</span><span style="color: #000000;">ci</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">else</span>
<span style="color: #000000;">ci</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">sprintf</span><span style="color: #0000FF;">(</span><span style="color: #008000;">"-%d"</span><span style="color: #0000FF;">,</span><span style="color: #000000;">ci</span><span style="color: #0000FF;">)</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">if</span> <span style="color: #000000;">i</span><span style="color: #0000FF;">=</span><span style="color: #000000;">1</span> <span style="color: #008080;">then</span> <span style="color: #000080;font-style:italic;">-- ie ^0</span>
<span style="color: #7060A8;">printf</span><span style="color: #0000FF;">(</span><span style="color: #000000;">1</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"%s"</span><span style="color: #0000FF;">,{</span><span style="color: #000000;">ci</span><span style="color: #0000FF;">})</span>
<span style="color: #008080;">elsif</span> <span style="color: #000000;">i</span><span style="color: #0000FF;">=</span><span style="color: #000000;">2</span> <span style="color: #008080;">then</span> <span style="color: #000080;font-style:italic;">-- ie ^1</span>
<span style="color: #7060A8;">printf</span><span style="color: #0000FF;">(</span><span style="color: #000000;">1</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"%sx"</span><span style="color: #0000FF;">,{</span><span style="color: #000000;">ci</span><span style="color: #0000FF;">})</span>
<span style="color: #008080;">else</span>
<span style="color: #7060A8;">printf</span><span style="color: #0000FF;">(</span><span style="color: #000000;">1</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"%sx^%d"</span><span style="color: #0000FF;">,{</span><span style="color: #000000;">ci</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;">if</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">for</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">procedure</span>
<span style="color: #008080;">procedure</span> <span style="color: #000000;">main</span><span style="color: #0000FF;">()</span>
<span style="color: #008080;">for</span> <span style="color: #000000;">n</span><span style="color: #0000FF;">=</span><span style="color: #000000;">1</span> <span style="color: #008080;">to</span> <span style="color: #000000;">10</span> <span style="color: #008080;">do</span> <span style="color: #000080;font-style:italic;">-- (0 to 9 really)</span>
<span style="color: #000000;">coef</span><span style="color: #0000FF;">(</span><span style="color: #000000;">n</span><span style="color: #0000FF;">);</span>
<span style="color: #7060A8;">printf</span><span style="color: #0000FF;">(</span><span style="color: #000000;">1</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"(x-1)^%d = "</span><span style="color: #0000FF;">,</span> <span style="color: #000000;">n</span><span style="color: #0000FF;">-</span><span style="color: #000000;">1</span><span style="color: #0000FF;">);</span>
<span style="color: #000000;">show</span><span style="color: #0000FF;">(</span><span style="color: #000000;">n</span><span style="color: #0000FF;">);</span>
<span style="color: #7060A8;">puts</span><span style="color: #0000FF;">(</span><span style="color: #000000;">1</span><span style="color: #0000FF;">,</span><span style="color: #008000;">'\n'</span><span style="color: #0000FF;">);</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">for</span>
<span style="color: #7060A8;">puts</span><span style="color: #0000FF;">(</span><span style="color: #000000;">1</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"\nprimes (&lt;=53):"</span><span style="color: #0000FF;">);</span>
<span style="color: #000080;font-style:italic;">-- coef(2); -- (needed to reset c, if we want to avoid saying 1 is prime...)</span>
<span style="color: #000000;">c</span><span style="color: #0000FF;">[</span><span style="color: #000000;">2</span><span style="color: #0000FF;">]</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">1</span> <span style="color: #000080;font-style:italic;">-- (this manages "", which is all that call did anyway...)</span>
<span style="color: #008080;">for</span> <span style="color: #000000;">n</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">2</span> <span style="color: #008080;">to</span> <span style="color: #000000;">53</span> <span style="color: #008080;">do</span>
<span style="color: #008080;">if</span> <span style="color: #000000;">is_aks_prime</span><span style="color: #0000FF;">(</span><span style="color: #000000;">n</span><span style="color: #0000FF;">)</span> <span style="color: #008080;">then</span>
<span style="color: #7060A8;">printf</span><span style="color: #0000FF;">(</span><span style="color: #000000;">1</span><span style="color: #0000FF;">,</span><span style="color: #008000;">" %d"</span><span style="color: #0000FF;">,</span> <span style="color: #000000;">n</span><span style="color: #0000FF;">);</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">for</span>
<span style="color: #7060A8;">puts</span><span style="color: #0000FF;">(</span><span style="color: #000000;">1</span><span style="color: #0000FF;">,</span><span style="color: #008000;">'\n'</span><span style="color: #0000FF;">);</span>
<span style="color: #008080;">if</span> <span style="color: #7060A8;">getc</span><span style="color: #0000FF;">(</span><span style="color: #000000;">0</span><span style="color: #0000FF;">)</span> <span style="color: #008080;">then</span> <span style="color: #008080;">end</span> <span style="color: #008080;">if</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">procedure</span>
<span style="color: #000000;">main</span><span style="color: #0000FF;">()</span>
<!--

85
Task/AKS-test-for-primes/REXX/aks-test-for-primes-3.rexx
View file

@ -4,17 +4,20 @@ arg p
if p = '' then
p = 10
numeric digits Max(10,Abs(p)%3)
call Combinations p
call Combis p
call Polynomials p
call ShowPrimes p
exit
Combinations:
Combis:
procedure expose comb.
arg p; p = Abs(p)
arg p
call Time('r')
say 'Combinations up to' p'...'
say Combs(p) 'combinations generated'
if p > 0 then
say 'Combinations up to' p'...'
else
say 'Combinations for' Abs(p)'...'
say Combinations(p) 'Combinations generated'
say Format(Time('e'),,3) 'seconds'
say
return
@ -61,9 +64,9 @@ say 'Primes...'
if p < 0 then do
p = Abs(p)
if prim.0 > 0 then
say p 'is prime'
say p 'is Prime'
else
say p 'is not prime'
say p 'is not Prime'
end
else do
do i = 1 to prim.0
@ -77,47 +80,52 @@ say Format(Time('e'),,3) 'seconds'
say
return
Combs:
-- Combinations
Combinations:
/* Combinations */
procedure expose comb.
arg x
-- Valid
if \ Iswhole(x) then
x = dummy
if x < 0 then
x = dummy
-- Recurring definition
arg xx
/* Validate */
if \ Whole(xx) then say abend
/* Recurring definition */
comb. = 1
do i = 1 to x
i1 = i-1
do j = 1 to i1
j1 = j-1
comb.i.j = comb.i1.j1+comb.i1.j
if xx < 0 then do
xx = -xx; m = xx%2; a = 1
do i = 1 to m
a = a*(xx-i+1)/i; comb.xx.i = a
end
do i = m+1 to xx-1
j = xx-i; comb.xx.i = comb.xx.j
end
return xx+1
end
else do
do i = 1 to xx
i1 = i-1
do j = 1 to i1
j1 = j-1; comb.i.j = comb.i1.j1+comb.i1.j
end
end
return (xx*xx+3*xx+2)/2
end
return (x*x+3*x+2)/2
Ppower:
-- Exponentiation
/* Exponentiation */
procedure expose poly. comb. work.
arg x,y
-- Validate
if x = '' then
x = dummy
if \ Iswhole(y) then
y = dummy
if y < 0 then
y = dummy
-- Exponentiate
/* Validate */
if x = '' then say abend
if \ Whole(y) then say abend
if y < 0 then say abend
/* Exponentiate */
numeric digits Digits()+2
wx = Words(x); wm = wx*y-y+1
poly. = 0; poly.0 = wm
select
when wx = 1 then
-- Power of a number
/* Power of a number */
poly.coef.1 = x**y
when wx = 2 then do
-- Newton's binomial
/* Newton's binomial */
a = Word(x,1); b = Word(x,2)
do i = 1 to wm
j = y-i+1; k = i-1
@ -125,7 +133,7 @@ select
end
end
otherwise do
-- Repeated multiplication
/* Repeated multiplication */
do i = 1 to wx
poly.coef.1.i = Word(x,i)
poly.coef.2.i = poly.coef.1.i
@ -151,14 +159,14 @@ select
end
end
numeric digits Digits()-2
-- Normalize coefs
/* Normalize coefs */
call Pnormalize
return wm
Parray2formula:
-- Array -> Formula
/* Array -> Formula */
procedure expose poly.
-- Generate formula
/* Generate formula */
y = ''; wm = poly.0
do i = 1 to wm
a = poly.coef.i
@ -187,8 +195,9 @@ do i = 1 to wm
end
if y = '' then
y = 0
return strip(y)
return Strip(y)
include Functions
include Numbers
include Polynomial
include Sequences

29
Task/AKS-test-for-primes/V-(Vlang)/aks-test-for-primes.v
View file

@ -17,35 +17,24 @@ fn main() {
println("$p: ${pp(bc(p))}")
}
for p := 2; p < 50; p++ {
if aks(p) {
print("$p ")
}
if aks(p) {print("${p} ")}
}
println('')
println("")
}
const e = [`²`,`³`,`⁴`,`⁵`,`⁶`,`⁷`]
fn pp(c []i64) string {
mut s := ''
if c.len == 1 {
return c[0].str()
}
if c.len == 1 {return c[0].str()}
p := c.len - 1
if c[p] != 1 {
s = c[p].str()
}
if c[p] != 1 {s = c[p].str()}
for i := p; i > 0; i-- {
s += "x"
if i != 1 {
s += e[i-2].str()
}
if i != 1 {s += e[i-2].str()}
d := c[i-1]
if d < 0 {
s += " - ${-d}"
} else {
s += " + $d"
}
if d < 0 {s += " - ${-d}"}
else {s += " + $d"}
}
return s
}
@ -55,9 +44,7 @@ fn aks(p int) bool {
c[p]--
c[0]++
for d in c {
if d%i64(p) != 0 {
return false
}
if d%i64(p) != 0 {return false}
}
return true
}

63
Task/Accumulator-factory/M2000-Interpreter/accumulator-factory.m2000
View file

@ -1,32 +1,33 @@
\\ M2000 Interpreter
\\ accumulator factory
foo=lambda acc=0 (n as double=0) -> {
\\ interpreter place this: read n as double=0 as first line of lambda function
if n=0 then =acc : exit
acc+=n
\\ acc passed as a closuer to lambda (a copy of acc in the result lambda function)
=lambda acc -> {
' if stack of values is empty then return a copy of acc
if empty then =acc : exit
read x
\\ x has no type here, can be any numeric type (also can be an object too)
\\ accumulator is double, and is a closure (a copy of acc in foo)
acc+=x
\\ any variable in M2000 hold first type
\\ if x is an object then we get error, except if object use this operator
x=acc
\\ so we return x type
=x
}
Module CheckIt {
Def VarType(n)=Type$(n)
foo=lambda (acc) -> {
=lambda acc -> {
if empty then =acc : exit
read x
acc+=x
=acc
}
}
Double a=1
x = foo(a)
call void x(5) ' Without Void a non zero value count as Error.
call foo(3)
print VarType(x())="Double", x(2.3)=8.3 ' Double literal
Single m=1
z=foo(m)
long L=5
? VarType(z(L))="Single", z(2.3)=8.3~ ' Single literal
Currency c=1
zc=foo(c)
? VarType(zc(5))="Currency", zc(2.3)=8.3# ' Currency literal
Decimal d=1
zd=foo(d)
? VarType(zd(5))="Decimal", zd(2.3)=8.3@ ' Decimal literal
Date dt=1
zdt=foo(dt)
? VarType(zdt(5))="Date", zdt(2.3)=8.3ud ' Date literal
Long Long LL=1
zdt=foo(LL)
? VarType(zdt(5))="Long Long", zdt(2.3)=8&& ' Long Long literal
}
x=foo(1&) ' 1& is long type (32bit)
call void x(5) ' 5 is double type (the default type for M2000)
call void foo(3#) ' void tell to interpreter to throw result, 3# is Currency type
print x(2.3@) ' print 8.3, 2.3@ is Decimal type
print foo()=4 ' print true
def ExpType$(z)=type$(z)
print ExpType$(foo())="Double"
print ExpType$(x(0&))="Long"
print ExpType$(x(0@))="Decimal"
print ExpType$(x())="Double"
print ExpType$(foo(20))="lambda"
CheckIt

13
Task/Additive-primes/REXX/additive-primes-2.rexx
View file

@ -6,16 +6,16 @@ numeric digits 16
if n = '' then
n = -500
show = (n > 0); n = Abs(n)
a = AdditivePrimes(n)
a = Additiveprimes(n)
if show then do
do i = 1 to a
call Charout ,right(addi.additiveprime.i,8)' '
call Charout ,Right(addi.additiveprime.i,8)' '
if i//10 = 0 then
say
end
say
end
say a 'additive primes found below' n
say a 'additive Primes found below' n
say Time('e') 'seconds'
exit
@ -44,17 +44,18 @@ p = Primes(x)
/* Collect additive primes */
n = 0
do i = 1 to p
q = prim.prime.i; s = 0
q = prim.Prime.i; s = 0
do j = 1 to Length(q)
s = s+Substr(q,j,1)
end
if IsPrime(s) then do
if Prime(s) then do
n = n+1; addi.additiveprime.n = q
end
end
/* Return number of additive primes */
return n
include Numbers
include Functions
include Numbers
include Sequences
include Abend

14
Task/Almkvist-Giullera-formula-for-pi/ALGOL-68/almkvist-giullera-formula-for-pi.alg
View file

@ -73,17 +73,17 @@ BEGIN
print( ( whole( n, 0 ), " | ", whole( almkvist giullera( n ), -44 ), newline ) )
OD;
FLOAT epsilon = FLOAT(10) ^ -70;
FLOAT prev := 0, pi := 0;
FLOAT prev := 0, pi approx := 0;
RATIONAL sum := zero // one;
FOR n FROM 0
WHILE
RATIONAL term = almkvist giullera( n ) // ( ten ^ ( 6 * n + 3 ) );
sum +:= term;
pi := long long sqrt( FLOAT(1) / sum );
ABS ( pi - prev ) >= epsilon
RATIONAL nth term = almkvist giullera( n ) // ( ten ^ ( 6 * n + 3 ) );
sum +:= nth term;
pi approx := long long sqrt( FLOAT(1) / sum );
ABS ( pi approx - prev ) >= epsilon
DO
prev := pi
prev := pi approx
OD;
print( ( newline, "Pi to 70 decimal places is:", newline ) );
print( ( fixed( pi, -72, 70 ), newline ) )
print( ( fixed( pi approx, -72, 70 ), newline ) )
END

89
Task/Almkvist-Giullera-formula-for-pi/Rust/almkvist-giullera-formula-for-pi.rs Normal file
View file

@ -0,0 +1,89 @@
use astro_float::{BigFloat, Consts, RoundingMode};
use num_bigint::BigInt;
use std::ops::{Div, Mul};
use std::str::FromStr;
const PR: usize = 228;
const RM: RoundingMode = RoundingMode::None;
fn factorial(n: u32) -> BigInt {
let mut p = BigInt::from(1);
for i in 2..=n {
p *= i;
}
p
}
fn exponent_term(n: u32) -> u32 {
6 * n + 3
}
fn integer_term(n: u32) -> BigInt {
let p = 532 * n * n + 126 * n + 9;
(p * BigInt::from(2).pow(5).mul(factorial(6 * n))).div(BigInt::from(3).mul(factorial(n).pow(6)))
}
fn nth_term(n: u32) -> BigFloat {
let divisor = BigInt::from(10).pow(exponent_term(n));
return BigFloat::from_str(&integer_term(n).to_string())
.unwrap()
.div(
&BigFloat::from_str(&divisor.to_string()).unwrap(),
PR,
RoundingMode::Up,
);
}
fn almkvist_guillera(float_precision: &BigFloat) -> BigFloat {
let mut c = Consts::new().unwrap();
let mut summed = nth_term(0);
let mut next_sum = summed.clone();
for n in 1..10000 {
next_sum = summed.add(&nth_term(n), PR, RM);
if (next_sum.sub(&summed, PR, RM)).abs()
< BigFloat::from(10.0).pow(&(-float_precision), PR, RM, &mut c)
{
break;
}
summed = next_sum.clone();
}
next_sum
}
fn main() {
let mut c = Consts::new().unwrap();
println!(
" N {:>21} {:>28} {:>20}\n{}\n",
"NUMERATOR",
"-EXP",
"TERM (rounded)",
"_".repeat(80)
);
for n in 0..10 {
let mut t = nth_term(n);
t.try_set_precision(64, RM, 64);
println!(
"{:>2} {:<44} {:>2} {}",
n,
integer_term(n),
exponent_term(n),
t
);
}
let pi_string = BigFloat::from(1.0)
.div(
&almkvist_guillera(&BigFloat::from(320)).sqrt(PR, RM),
PR,
RM,
)
.to_string();
println!(
"\nAlmkvist-Guillera π to 75 digits is {}\n",
pi_string[..pi_string.len() - 6].to_string()
);
let library_pi_string = Consts::pi(&mut c, PR, RM).to_string();
println!(
"BigFloat (astro_float) library π is {}",
library_pi_string[..library_pi_string.len() - 5].to_string()
);
}

1
Task/Almost-prime/REXX/almost-prime-3.rexx
View file

@ -32,5 +32,6 @@ say Format(Time('e'),,3) 'seconds'
exit
include Numbers
include Sequences
include Functions
include Abend

26
Task/Amb/FutureBasic/amb.basic Normal file
View file

@ -0,0 +1,26 @@
CFStringRef local fn Amb( a1 as CFArrayRef, a2 as CFArrayRef, a3 as CFArrayRef, a4 as CFArrayRef )
for CFStringRef s1 in a1
for CFStringRef s2 in a2
for CFStringRef s3 in a3
for CFStringRef s4 in a4
if ( ucc(s1,len(s1)-1) == ucc(s2) && ucc(s2,len(s2)-1) == ucc(s3) && ucc(s3,len(s3)-1) == ucc(s4) )
return concat @" ",(s1,s2,s3,s4)
end if
next
next
next
next
end fn = @""
void local fn DoIt
CFArrayRef a1 = @[@"the",@"that",@"a"]
CFArrayRef a2 = @[@"frog",@"elephant",@"thing"]
CFArrayRef a3 = @[@"walked",@"treaded",@"grows"]
CFArrayRef a4 = @[@"slowly",@"quickly"]
print fn Amb( a1, a2, a3, a4 )
end fn
fn DoIt
HandleEvents

18
Task/Anagrams/V-(Vlang)/anagrams.v
View file

@ -1,26 +1,18 @@
import os
fn main(){
words := os.read_lines('unixdict.txt')?
words := os.read_lines('unixdict.txt')!
mut m := map[string][]string{}
mut ma := 0
for word in words {
mut letters := word.split('')
letters.sort()
sorted_word := letters.join('')
if sorted_word in m {
m[sorted_word] << word
} else {
m[sorted_word] = [word]
}
if m[sorted_word].len > ma {
ma = m[sorted_word].len
}
if sorted_word in m {m[sorted_word] << word}
else {m[sorted_word] = [word]}
if m[sorted_word].len > ma {ma = m[sorted_word].len}
}
for _, a in m {
if a.len == ma {
println(a)
}
if a.len == ma {println(a)}
}
}

11
Task/Anonymous-recursion/FutureBasic/anonymous-recursion.basic Normal file
View file

@ -0,0 +1,11 @@
local fn Fibonacci( n as long ) as long
if n < 0 then printf @"Invalid argument: \b" : return n
if n < 2 then return n else return fn Fibonacci( n - 1 ) + fn Fibonacci( n - 2 )
end fn = 0
print fn Fibonacci(20)
print fn Fibonacci(30)
print fn Fibonacci(-10)
print fn Fibonacci(10)
handleevents

12
Task/Anonymous-recursion/Jq/anonymous-recursion-2.jq
View file

@ -1,8 +1,8 @@
def fib(n):
def aux: if . == 0 then 0
elif . == 1 then 1
else (. - 1 | aux) + (. - 2 | aux)
end;
if n < 0 then error("negative arguments not allowed")
else n | aux
end ;
else [2, 0, 1]
| recurse( if .[0] > n then empty
else [ .[0]+1, .[2], .[1]+.[2] ]
end)
| .[1]
end;

8
Task/Anonymous-recursion/Jq/anonymous-recursion-3.jq Normal file
View file

@ -0,0 +1,8 @@
def fib(n):
def aux: if . == 0 then 0
elif . == 1 then 1
else (. - 1 | aux) + (. - 2 | aux)
end;
if n < 0 then error("negative arguments not allowed")
else n | aux
end ;

6
Task/Anonymous-recursion/M2000-Interpreter/anonymous-recursion-1.m2000
View file

@ -1,6 +0,0 @@
A$={{ Module "Fibonacci" : Read X :If X<0 then {Error {X<0}} Else Fib=Lambda (x)->if(x>1->fib(x-1)+fib(x-2), x) : =fib(x)}}
Try Ok {
Print Function(A$, -12)
}
If Error or Not Ok Then Print Error$
Print Function(A$, 12)=144 ' true

11
Task/Anonymous-recursion/M2000-Interpreter/anonymous-recursion-2.m2000
View file

@ -1,11 +0,0 @@
Function fib(x) {
If x<0 then Error "argument outside of range"
If x<2 then =x : exit
Def fib1(x)=If(x>1->lambda(x-1)+lambda(x-2), x)
=fib1(x)
}
Module CheckIt (&k()) {
Print k(12)
}
CheckIt &Fib()
Print fib(-2) ' error

23
Task/Anonymous-recursion/M2000-Interpreter/anonymous-recursion-3.m2000
View file

@ -1,23 +0,0 @@
fib=lambda -> {
fib1=lambda (x)->If(x>1->lambda(x-1)+lambda(x-2), x)
=lambda fib1 (x) -> {
If x<0 then Error "argument outside of range"
If x<2 then =x : exit
=fib1(x)
}
}() ' using () execute this lambda so fib get the returned lambda
Module CheckIt (&k()) {
Print k(12)
}
CheckIt &Fib()
Try {
Print fib(-2)
}
Print Error$
Z=Fib
Print Z(12)
Dim a(10)
a(3)=Z
Print a(3)(12)=144
Inventory Alfa = "key1":=Z
Print Alfa("key1")(12)=144

24
Task/Anonymous-recursion/M2000-Interpreter/anonymous-recursion-4.m2000
View file

@ -1,24 +0,0 @@
Class Something {
\\ this class is a global function
\\ return a group with a value with one parameter
private:
\\ we can use lambda(), but here we use .fib1() as This.fib1()
fib1=lambda (x)->If(x>1->.fib1(x-1)+.fib1(x-2), x)
public:
Value (x) {
If x<0 then Error "argument outside of range"
If x<2 then =x : exit
=This.fib1(x) \\ we can omit This using .fib1(x)
}
}
K=Something() ' K is a static group here
Print k(12)=144
Dim a(10)
a(4)=Group(K)
Print a(4)(12)=144
pk->Something() ' pk is a pointer to group (object in M2000)
\\ pointers need Eval to process arguments
Print Eval(pk, 12)=144
Inventory Alfa = "Key2":=Group(k), 10*10:=pk
Print Alfa("Key2")(12)=144
Print Eval(Alfa("100"),12)=144, Eval(Alfa(100),12)=144

4
Task/Anonymous-recursion/M2000-Interpreter/anonymous-recursion.m2000 Normal file
View file

@ -0,0 +1,4 @@
module Anonymus_lambda {
Print lambda (x as long long)->{=If(x>1->lambda(x-1)+lambda(x-2), x)}(10)=55
}
Anonymus_Lambda

3
Task/Anti-primes/ALGOL-68/anti-primes.alg
View file

@ -1,6 +1,7 @@
BEGIN # find some anti-primes: numbers with more divisors than the #
# previous numbers #
REF[]INT ndc := HEAP[ 1 : 0 ]INT; # table of divisor counts #
HEAP[ 1 : 0 ]INT empty list;
REF[]INT ndc := empty list; # table of divisor counts #
INT max divisors := 0;
INT a count := 0;
FOR n WHILE a count < 20 DO

1
Task/Anti-primes/REXX/anti-primes-3.rexx
View file

@ -40,4 +40,5 @@ return n
include Numbers
include Functions
include Sequences
include Abend

35
Task/Apply-a-digital-filter-direct-form-II-transposed-/ALGOL-68/apply-a-digital-filter-direct-form-ii-transposed-.alg
View file

@ -1,5 +1,4 @@
BEGIN # apply a digital filter #
# the lower bounds of a, b, signal and result must all be equal #
PROC filter = ( []REAL a, b, signal, REF[]REAL result )VOID:
IF LWB a /= LWB b OR LWB a /= LWB signal OR LWB a /= LWB result THEN
print( ( "Array lower bounds must be equal for filter", newline ) );
@ -11,25 +10,27 @@ BEGIN # apply a digital filter #
FOR j FROM LWB b TO IF i > UPB b THEN UPB b ELSE i FI DO
tmp +:= b[ j ] * signal[ LWB signal + ( i - j ) ]
OD;
FOR j FROM LWB a + 1 TO IF i > UPB a THEN UPB a ELSE i FI DO
FOR j FROM LWB a + 1 TO IF i > UPB a THEN UPB a ELSE i FI DO
tmp -:= a[ j ] * result[ LWB result + ( i - j ) ]
OD;
result[ i ] := tmp / a[ LWB a ]
OD
FI # filter # ;
[ 4 ]REAL a := []REAL( 1, -2.77555756e-16, 3.33333333e-01, -1.85037171e-17 );
[ 4 ]REAL b := []REAL( 0.16666667, 0.5, 0.5, 0.16666667 );
[ 20 ]REAL signal
:= []REAL( -0.917843918645, 0.141984778794, 1.20536903482, 0.190286794412
, -0.662370894973, -1.00700480494, -0.404707073677, 0.800482325044
, 0.743500089861, 1.01090520172, 0.741527555207, 0.277841675195
, 0.400833448236, -0.2085993586, -0.172842103641, -0.134316096293
, 0.0259303398477, 0.490105989562, 0.549391221511, 0.9047198589
);
[ 20 ]REAL result;
filter( a, b, signal, result );
FOR i FROM LWB result TO UPB result DO
print( ( " ", fixed( result[ i ], -9, 6 ) ) );
IF i MOD 5 /= 0 THEN print( ( ", " ) ) ELSE print( ( newline ) ) FI
OD
BEGIN
[ 4 ]REAL a := []REAL( 1, -2.77555756e-16, 3.33333333e-01, -1.85037171e-17 );
[ 4 ]REAL b := []REAL( 0.16666667, 0.5, 0.5, 0.16666667 );
[ 20 ]REAL signal
:= []REAL( -0.917843918645, 0.141984778794, 1.20536903482, 0.190286794412
, -0.662370894973, -1.00700480494, -0.404707073677, 0.800482325044
, 0.743500089861, 1.01090520172, 0.741527555207, 0.277841675195
, 0.400833448236, -0.2085993586, -0.172842103641, -0.134316096293
, 0.0259303398477, 0.490105989562, 0.549391221511, 0.9047198589
);
[ 20 ]REAL result;
filter( a, b, signal, result );
FOR i FROM LWB result TO UPB result DO
print( ( " ", fixed( result[ i ], -9, 6 ) ) );
IF i MOD 5 /= 0 THEN print( ( ", " ) ) ELSE print( ( newline ) ) FI
OD
END
END

38
Task/Apply-a-digital-filter-direct-form-II-transposed-/Phix/apply-a-digital-filter-direct-form-ii-transposed-.phix
View file

@ -1,22 +1,20 @@
(phixonline)-->
<span style="color: #008080;">with</span> <span style="color: #008080;">javascript_semantics</span>
<span style="color: #008080;">function</span> <span style="color: #000000;">direct_form_II_transposed_filter</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: #000000;">b</span><span style="color: #0000FF;">,</span> <span style="color: #000000;">signal</span><span style="color: #0000FF;">)</span>
<span style="color: #004080;">sequence</span> <span style="color: #000000;">result</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;">length</span><span style="color: #0000FF;">(</span><span style="color: #000000;">signal</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;">signal</span><span style="color: #0000FF;">)</span> <span style="color: #008080;">do</span>
<span style="color: #004080;">atom</span> <span style="color: #000000;">tmp</span> <span style="color: #0000FF;">=</span> <span style="color: #000000;">0</span>
<span style="color: #008080;">for</span> <span style="color: #000000;">j</span><span style="color: #0000FF;">=</span><span style="color: #000000;">1</span> <span style="color: #008080;">to</span> <span style="color: #7060A8;">min</span><span style="color: #0000FF;">(</span><span style="color: #000000;">i</span><span style="color: #0000FF;">,</span><span style="color: #7060A8;">length</span><span style="color: #0000FF;">(</span><span style="color: #000000;">b</span><span style="color: #0000FF;">))</span> <span style="color: #008080;">do</span> <span style="color: #000000;">tmp</span> <span style="color: #0000FF;">+=</span> <span style="color: #000000;">b</span><span style="color: #0000FF;">[</span><span style="color: #000000;">j</span><span style="color: #0000FF;">]*</span><span style="color: #000000;">signal</span><span style="color: #0000FF;">[</span><span style="color: #000000;">i</span><span style="color: #0000FF;">-</span><span style="color: #000000;">j</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;">for</span> <span style="color: #000000;">j</span><span style="color: #0000FF;">=</span><span style="color: #000000;">2</span> <span style="color: #008080;">to</span> <span style="color: #7060A8;">min</span><span style="color: #0000FF;">(</span><span style="color: #000000;">i</span><span style="color: #0000FF;">,</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;">tmp</span> <span style="color: #0000FF;">-=</span> <span style="color: #000000;">a</span><span style="color: #0000FF;">[</span><span style="color: #000000;">j</span><span style="color: #0000FF;">]*</span><span style="color: #000000;">result</span><span style="color: #0000FF;">[</span><span style="color: #000000;">i</span><span style="color: #0000FF;">-</span><span style="color: #000000;">j</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;">result</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: #000000;">tmp</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: #008080;">end</span> <span style="color: #008080;">for</span>
<span style="color: #008080;">return</span> <span style="color: #000000;">result</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>
with javascript_semantics
function direct_form_II_transposed_filter(sequence a, b, signal)
sequence result = repeat(0,length(signal))
for i=1 to length(signal) do
atom tmp = 0
for j=1 to min(i,length(b)) do tmp += b[j]*signal[i-j+1] end for
for j=2 to min(i,length(a)) do tmp -= a[j]*result[i-j+1] end for
result[i] = tmp/a[1]
end for
return result
end function
<span style="color: #008080;">constant</span> <span style="color: #000000;">acoef</span> <span style="color: #0000FF;">=</span> <span style="color: #0000FF;">{</span><span style="color: #000000;">1.00000000</span><span style="color: #0000FF;">,</span> <span style="color: #0000FF;">-</span><span style="color: #000000;">2.77555756e-16</span><span style="color: #0000FF;">,</span> <span style="color: #000000;">3.33333333e-01</span><span style="color: #0000FF;">,</span> <span style="color: #0000FF;">-</span><span style="color: #000000;">1.85037171e-17</span><span style="color: #0000FF;">},</span>
<span style="color: #000000;">bcoef</span> <span style="color: #0000FF;">=</span> <span style="color: #0000FF;">{</span><span style="color: #000000;">0.16666667</span><span style="color: #0000FF;">,</span> <span style="color: #000000;">0.5</span><span style="color: #0000FF;">,</span> <span style="color: #000000;">0.5</span><span style="color: #0000FF;">,</span> <span style="color: #000000;">0.16666667</span><span style="color: #0000FF;">},</span>
<span style="color: #000000;">signal</span> <span style="color: #0000FF;">=</span> <span style="color: #0000FF;">{-</span><span style="color: #000000;">0.917843918645</span><span style="color: #0000FF;">,</span><span style="color: #000000;">0.141984778794</span><span style="color: #0000FF;">,</span><span style="color: #000000;">1.20536903482</span><span style="color: #0000FF;">,</span><span style="color: #000000;">0.190286794412</span><span style="color: #0000FF;">,-</span><span style="color: #000000;">0.662370894973</span><span style="color: #0000FF;">,</span>
<span style="color: #0000FF;">-</span><span style="color: #000000;">1.00700480494</span><span style="color: #0000FF;">,-</span><span style="color: #000000;">0.404707073677</span><span style="color: #0000FF;">,</span><span style="color: #000000;">0.800482325044</span><span style="color: #0000FF;">,</span><span style="color: #000000;">0.743500089861</span><span style="color: #0000FF;">,</span><span style="color: #000000;">1.01090520172</span><span style="color: #0000FF;">,</span>
<span style="color: #000000;">0.741527555207</span><span style="color: #0000FF;">,</span><span style="color: #000000;">0.277841675195</span><span style="color: #0000FF;">,</span><span style="color: #000000;">0.400833448236</span><span style="color: #0000FF;">,-</span><span style="color: #000000;">0.2085993586</span><span style="color: #0000FF;">,-</span><span style="color: #000000;">0.172842103641</span><span style="color: #0000FF;">,</span>
<span style="color: #0000FF;">-</span><span style="color: #000000;">0.134316096293</span><span style="color: #0000FF;">,</span><span style="color: #000000;">0.0259303398477</span><span style="color: #0000FF;">,</span><span style="color: #000000;">0.490105989562</span><span style="color: #0000FF;">,</span><span style="color: #000000;">0.549391221511</span><span style="color: #0000FF;">,</span><span style="color: #000000;">0.9047198589</span><span style="color: #0000FF;">}</span>
constant acoef = {1.00000000, -2.77555756e-16, 3.33333333e-01, -1.85037171e-17},
bcoef = {0.16666667, 0.5, 0.5, 0.16666667},
signal = {-0.917843918645,0.141984778794,1.20536903482,0.190286794412,-0.662370894973,
-1.00700480494,-0.404707073677,0.800482325044,0.743500089861,1.01090520172,
0.741527555207,0.277841675195,0.400833448236,-0.2085993586,-0.172842103641,
-0.134316096293,0.0259303398477,0.490105989562,0.549391221511,0.9047198589}
<span style="color: #7060A8;">pp</span><span style="color: #0000FF;">(</span><span style="color: #000000;">direct_form_II_transposed_filter</span><span style="color: #0000FF;">(</span><span style="color: #000000;">acoef</span><span style="color: #0000FF;">,</span> <span style="color: #000000;">bcoef</span><span style="color: #0000FF;">,</span> <span style="color: #000000;">signal</span><span style="color: #0000FF;">),{</span><span style="color: #004600;">pp_FltFmt</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"%9.6f"</span><span style="color: #0000FF;">,</span><span style="color: #004600;">pp_Maxlen</span><span style="color: #0000FF;">,</span><span style="color: #000000;">110</span><span style="color: #0000FF;">})</span>
<!--
pp(direct_form_II_transposed_filter(acoef, bcoef, signal),{pp_FltFmt,"%9.6f",pp_Maxlen,110})

17
Task/Arbitrary-precision-integers-included-/Refal/arbitrary-precision-integers-included-.refal Normal file
View file

@ -0,0 +1,17 @@
$ENTRY Go {
, <Pow (5) <Pow (4) <Pow (3) 2>>>: e.X
, <Symb e.X>: e.Y
, <First 20 e.Y>: (e.DF) e.1
, <Last 20 e.Y>: (e.2) e.DL
, <Lenw e.Y>: s.L e.Y
= <Prout e.DF '...' e.DL>
<Prout 'Length: ' s.L>;
}
Pow {
(e.N) 0 = 1;
(e.N) e.P, <Divmod (e.P) 2>: {
(e.P2) 0, <Pow (e.N) e.P2>: e.X = <Mul (e.X) e.X>;
(e.P2) 1, <Pow (e.N) e.P2>: e.X = <Mul (e.N) <Mul (e.X) e.X>>;
};
};

8
Task/Arbitrary-precision-integers-included-/SETL/arbitrary-precision-integers-included-.setl Normal file
View file

@ -0,0 +1,8 @@
program p_5432;
x := 5 ** 4 ** 3 ** 2;
y := str x;
print("First 20 digits: ", y(1..20));
print("Last 20 digits: ", y(#y-19..#y));
print("Amount of digits:", #y);
end program;

27
Task/Arithmetic-Complex/Standard-ML/arithmetic-complex.ml
View file

@ -1,15 +1,23 @@
(* Signature for complex numbers *)
signature COMPLEX = sig
type num
type num
val complex : real * real -> num
(* creation *)
val complex : real * real -> num
val negative : num -> num
val plus : num -> num -> num
val minus : num -> num -> num
val times : num -> num -> num
val invert : num -> num
val print_number : num -> unit
(* operations *)
val negative : num -> num
val plus : num -> num -> num
val minus : num -> num -> num
val times : num -> num -> num
val invert : num -> num
(* polar form *)
val abs : num -> real
val arg : num -> real
(* output *)
val print_number : num -> unit
end;
(* Actual implementation *)
@ -29,6 +37,9 @@ structure Complex :> COMPLEX = struct
(a / denom, ~b / denom)
end
fun abs (x, y) = Math.sqrt (x*x + y*y)
fun arg (x, y) = Math.atan2(y, x)
fun print_number (a, b) =
print (Real.toString(a) ^ " + " ^ Real.toString(b) ^ "i\n")
end;

12
Task/Arithmetic-geometric-mean/FutureBasic/arithmetic-geometric-mean.basic Normal file
View file

@ -0,0 +1,12 @@
double local fn agm( a as double, g as double )
double ta
do
ta = a
a = (a + g) / 2
g = sqr(ta * g)
until ( a == ta )
end fn = a
print fn agm( 1, 1/sqr(2) )
HandleEvents

2
Task/Arithmetic-numbers/REXX/arithmetic-numbers.rexx → Task/Arithmetic-numbers/REXX/arithmetic-numbers-1.rexx
View file

@ -39,7 +39,7 @@ procedure expose divi.
arg x
/* Cf definition */
s = Sigma(x)
if Iswhole(s/divi.0) then
if Whole(s/divi.0) then
return 1
else
return 0

76
Task/Arithmetic-numbers/REXX/arithmetic-numbers-2.rexx Normal file
View file

@ -0,0 +1,76 @@
parse Version version
say version; say 'Arithmetic numbers'; say
Call time 'R'
numeric digits 9
a = 0; c = 0
do i = 1
/* Is the number arithmetic? */
if Arithmetic(i) then do
a = a+1
/* Is the number composite? */
if divi.0 > 2 then
c = c+1
/* Output control */
if a <= 100 then do
if a = 1 then
say 'First 100 arithmetic numbers are'
call Charout ,Right(i,4)
if a//10 = 0 then
say
if a = 100 then
say
end
if a = 100 | a = 1000 | a = 10000 | a = 100000 | a = 1000000 then do
say 'The' a'th arithmetic number is' i
say 'Of the first' a 'numbers' c 'are composite'
say
end
/* Max 1m, higher takes too long */
if a = 1000000 then
leave
end
end
say Format(Time('e'),,3) 'seconds'
exit
Arithmetic:
/* Is a number arithmetic? function */
procedure expose divi.
arg x
/* Cf definition */
s = Sigma(x)
if Whole(s/divi.0) then
return 1
else
return 0
Sigma:
/* Sigma = Sum of all divisors of x including 1 and x */
procedure expose divi.
arg xx
/* Fast values */
if xx = 1 then do
divi.0 = 1
return 1
end
/* Euclid's method */
m = xx//2; yy = 1+xx; n = 2
do j = 2+m by 1+m while j*j < xx
if xx//j = 0 then do
yy = yy+j+xx%j; n = n+2
end
end
if j*j = xx then do
yy = yy+j; n = n+1
end
/* Store number of divisors */
divi.0 = n
/* Return sum */
return yy
Whole:
/* Is a number integer? */
procedure
arg xx
/* Formula */
return Datatype(xx,'w')

42
Task/Arrays/FutureBasic/arrays.basic
View file

@ -1,8 +1,8 @@
window 1, @"FutureBasic Arrays", (0,0,480,450)
begin globals
dynamic gA1(10) as long
dynamic gA2(10) as Str255
dynamic gA1(10) as long
dynamic gA2(10) as Str255
end globals
void local fn CType
@ -11,12 +11,7 @@ void local fn CType
text ,, fn ColorGray
print @"// C-type fixed-length"
text
long a1(4)
a1(0) = 10
a1(1) = 5
a1(2) = 12
a1(3) = 8
a1(4) = 7
long a1(4) = {10,5,12,8,7}
for i = 0 to 4
print a1(i),
next
@ -30,12 +25,7 @@ void local fn CType
next
print
CFStringRef a2(4)
a2(0) = @"Alpha"
a2(1) = @"Bravo"
a2(2) = @"Tango"
a2(3) = @"Delta"
a2(4) = @"Echo"
CFStringRef a2(4) = {@"Alpha",@"Bravo",@"Tango",@"Delta",@"Echo"}
for i = 0 to 4
print a2(i),
next
@ -111,32 +101,27 @@ void local fn CoreFoundationMutableFixedLength
print @"// CoreFoundation (CF) mutable, fixed-length"
text
CFMutableArrayRef a1 = fn MutableArrayWithCapacity(3)
MutableArrayAddObject( a1, @79 )
MutableArrayAddObject( a1, @43 )
MutableArrayAddObject( a1, @101)
a1[0] = @79 : a1[1] = @43 : a1[2] = @101
for i = 0 to len(a1) - 1
print a1[i],
next
print
MutableArrayReplaceObjectAtIndex( a1, @15, 2 )
a1[2] = @15
for i = 0 to len(a1) - 1
print a1[i],
next
print
CFMutableArrayRef a2 = fn MutableArrayWithCapacity(4)
MutableArrayAddObject( a2, @"Whisky" )
MutableArrayAddObject( a2, @"Oscar" )
MutableArrayAddObject( a2, @"Yankee" )
MutableArrayAddObject( a2, @"Sierra" )
a2[0] = @"Whisky" : a2[1] = @"Oscar" : a2[2] = @"Yankee" : a2[3] = @"Sierra"
for i = 0 to len(a2) - 1
print a2[i],
next
print
MutableArrayReplaceObjectAtIndex( a2, @"Xray", 1 )
MutableArrayReplaceObjectAtIndex( a2, @"Zulu", 3 )
a2[1] = @"Xray"
a2[3] = @"Zulu"
for i = 0 to len(a2) - 1
print a2[i],
next
@ -158,8 +143,8 @@ void local fn CoreFoundationMutableDynamic
next
print
MutableArrayReplaceObjectAtIndex( a1, @"Foxtrot", 0 )
MutableArrayReplaceObjectAtIndex( a1, @"Hotel", 2 )
a1[0] = @"Foxtrot"
a1[2] = @"Hotel"
for i = 0 to len(a1) - 1
print a1[i],
next
@ -174,10 +159,7 @@ void local fn FB_MDA
print @"// FB MDA - mutable, dynamic, multi-dimensional"
text
mda_add = @"Alpha"
mda_add = @"Romeo"
mda_add = @"Mike"
mda() = {@"Alpha",@"Romeo",@"Mike"}
for i = 0 to mda_count - 1
print mda(i),
next

8
Task/Associative-array-Creation/FutureBasic/associative-array-creation.basic
View file

@ -4,10 +4,10 @@ void local fn DoIt
CFDictionaryRef dict2 = @{@"A":@"Alpha", @"B":@"Bravo", @"C":@"Charlie", @"D":@"Delta"} // shorthand syntax
CFMutableDictionaryRef dict3 = fn MutableDictionaryNew
MutableDictionarySetObjectForKey( dict3, @"Alpha", @"A" )
MutableDictionarySetObjectForKey( dict3, @"Bravo", @"B" )
MutableDictionarySetObjectForKey( dict3, @"Charlie", @"C" )
MutableDictionarySetObjectForKey( dict3, @"Delta", @"D" )
dict3[@"A"] = @"Alpha"
dict3[@"B"] = @"Bravo"
dict3[@"C"] = @"Charlie"
dict3[@"D"] = @"Delta"
CFMutableDictionaryRef dict4 = fn MutableDictionaryWithDictionary( @{@"A":@"Alpha", @"B":@"Bravo", @"C":@"Charlie", @"D":@"Delta"} )

33
Task/Associative-array-Merging/M2000-Interpreter/associative-array-merging.m2000 Normal file
View file

@ -0,0 +1,33 @@
module mergeList {
a=list:="name":="Rocket Skates", "price":=12.75, "color":="yellow"
b=list:="price":=15.25, "color":="red", "year":=1974
c=list
bb=each(a)
while bb {
append c, eval$(bb!):=eval(bb)
}
bb=each(b)
while bb {
if exist(c, eval$(bb!)) then
return c, eval$(bb!):=eval(bb)
else
append c, eval$(bb!):=eval(bb)
end if
}
bb=each(c)
Print format$(" |{0:8}|{1}", "Key", "Value")
Gosub simple
while bb {
fun1(bb^+1, eval$(bb!),eval(bb))
}
Gosub simple
sub fun1(n, a as string, b as variant)
local string c=if$(type$(b)="String"->quote$(b), ""+b)
Print format$("{0::-2}|{1:-8}|{2:15}|", n, quote$(a), c)
end sub
simple:
Print "--+--------+---------------+"
Return
}
mergeList

14
Task/Averages-Mean-angle/FutureBasic/averages-mean-angle.basic Normal file
View file

@ -0,0 +1,14 @@
double local fn MeanAngle( angles as CFArrayRef )
long count = len(angles)
double sinSum = 0.0, cosSum = 0.0
for long i = 0 to count - 1
sinSum += sin(dblval(angles[i]) * M_PI / 180.0)
cosSum += cos(dblval(angles[i]) * M_PI / 180.0)
next
end fn = fn atan2(sinSum / count, cosSum / count) * 180.0 / M_PI
print @"Mean angle of [350,10] = ";fn MeanAngle( @[@350,@10] )
print @"Mean angle of [90,180,270,360] = ";fn MeanAngle( @[@90,@180,@270,@360] )
print @"Mean angle of [10,20,30] = ";fn MeanAngle( @[@10,@20,@30] )
HandleEvents

52
Task/Averages-Mean-angle/M2000-Interpreter/averages-mean-angle.m2000 Normal file
View file

@ -0,0 +1,52 @@
module Mean_angle (useDif as boolean) {
meanangle= lambda useDif->{
if useDif then
sin1=lambda ->{
data round(sin(number)-0.00000001,8)
}
cos1=lambda ->{
data round(cos(number)-0.00000001, 8)
}
else
sin1=lambda ->{
data round(sin(number),8)
}
cos1=lambda ->{
data round(cos(number), 8)
}
end if
= lambda sin1, cos1 ->{
' [] is a stack object with all parameters
' array([]) put the parameters in an array
a=array([])
s=a#map(sin1)#sum()/len(a)
c=a#map(cos1)#sum()/len(a)
if s>0 and c>0 then
=round(atn(s/c), 1)
else.if c<0 then
=round(atn(s/c)+180, 1)
else.if s<0 and c>0 then
=round(atn(s/c)+360, 1)
else
=0
end if
}
}() ' execute lambda now, so meanangle has the inner lambda
? meanangle(350, 10)=360 ' false with useDif=false
? meanangle(90, 180, 270, 360)=225 ' false with useDif=false
? meanangle(-270, -180, -90, 0)=225' false with useDif=false
? meanangle(355, 5, 15)=5
? meanangle(335, 345, 355)=345
? meanangle(40, 60)=50
? meanangle(-60, -40)=310
? meanangle(350, 20)=5
? meanangle(340, 10)=355
? meanangle(10, 20, 30)=20
? meanangle(355, 10, 20, 30, 45)=20
? meanangle(370)=10
? meanangle(180)=180
? meanangle(180, 270)=225
}
Mean_angle true
Mean_angle false

34
Task/Averages-Mean-angle/QB64/averages-mean-angle.qb64 Normal file
View file

@ -0,0 +1,34 @@
Const PI# = 3.1415926535897932
ReDim angles1#(1 To 2)
angles1#(1) = 350
angles1#(2) = 10
ReDim angles2#(1 To 4)
angles2#(1) = 90
angles2#(2) = 180
angles2#(3) = 270
angles2#(4) = 360
ReDim angles3#(1 To 3)
angles3#(1) = 10
angles3#(2) = 20
angles3#(3) = 30
Print Using "Mean for angles 1 is : ####.## degrees"; MeanAngle#(angles1#())
Print Using "Mean for angles 2 is : ####.## degrees"; MeanAngle#(angles2#())
Print Using "Mean for angles 3 is : ####.## degrees"; MeanAngle#(angles3#())
End
Function MeanAngle# (angles#())
length# = UBound(angles#) - LBound(angles#) + 1
sinSum# = 0.0
cosSum# = 0.0
For i% = LBound(angles#) To UBound(angles#)
sinSum# = sinSum# + Sin(angles#(i%) * PI# / 180.0)
cosSum# = cosSum# + Cos(angles#(i%) * PI# / 180.0)
Next i%
MeanAngle# = _Atan2(sinSum# / length#, cosSum# / length#) * 180.0 / PI#
End Function

55
Task/Averages-Mean-angle/QBasic/averages-mean-angle.basic Normal file
View file

@ -0,0 +1,55 @@
DECLARE FUNCTION Atan2# (y AS DOUBLE, x AS DOUBLE)
DECLARE FUNCTION MeanAngle# (angles#())
CONST PI# = 3.141592653589793#
REDIM angles1#(1 TO 2)
angles1#(1) = 350
angles1#(2) = 10
REDIM angles2#(1 TO 4)
angles2#(1) = 90
angles2#(2) = 180
angles2#(3) = 270
angles2#(4) = 360
REDIM angles3#(1 TO 3)
angles3#(1) = 10
angles3#(2) = 20
angles3#(3) = 30
PRINT USING "Mean for angles 1 is : ####.## degrees"; MeanAngle#(angles1#())
PRINT USING "Mean for angles 2 is : ####.## degrees"; MeanAngle#(angles2#())
PRINT USING "Mean for angles 3 is : ####.## degrees"; MeanAngle#(angles3#())
FUNCTION Atan2# (y AS DOUBLE, x AS DOUBLE)
IF x > 0 THEN
Atan2# = ATN(y / x)
ELSEIF x < 0 THEN
IF y >= 0 THEN
Atan2# = ATN(y / x) + PI#
ELSE
Atan2# = ATN(y / x) - PI#
END IF
ELSE ' x = 0
IF y > 0 THEN
Atan2# = PI# / 2
ELSEIF y < 0 THEN
Atan2# = -PI# / 2
ELSE ' y = 0
Atan2# = 0
END IF
END IF
END FUNCTION
FUNCTION MeanAngle# (angles#())
length# = UBOUND(angles#) - LBOUND(angles#) + 1
sinSum# = 0!
cosSum# = 0!
FOR i% = LBOUND(angles#) TO UBOUND(angles#)
sinSum# = sinSum# + SIN(angles#(i%) * PI# / 180!)
cosSum# = cosSum# + COS(angles#(i%) * PI# / 180!)
NEXT i%
MeanAngle# = Atan2#(sinSum# / length#, cosSum# / length#) * 180! / PI#
END FUNCTION

34
Task/Averages-Mean-angle/Standard-ML/averages-mean-angle.ml Normal file
View file

@ -0,0 +1,34 @@
(* some helper functions *)
val sum = List.foldl (op +) 0.0
val tau = 2.0 * Math.pi
fun deg2rad x = (x / 360.0) * tau
fun rad2deg x = (x / tau) * 360.0
fun printList' [] = print "\b\b]"
| printList' (x::xs) = (print (Int.toString x); print ", "; printList' xs)
fun printList [] = print "[]"
| printList xs = (print "["; printList' xs)
(* the main function *)
fun meanAngle xs =
let
val realLen = Real.fromInt (length xs)
in
Math.atan2((sum (map Math.sin xs))/realLen, (sum (map Math.cos xs))/realLen)
end
(* try it out *)
val angless = [[350, 10], [90, 180, 270, 360], [10, 20, 30]]
fun doAngleMeans [] = ()
| doAngleMeans (angles::rest) =
let
val rads = map (deg2rad o Real.fromInt) angles
val _ = print "Mean angle of: "
val _ = printList angles
val _ = print " = "
val _ = print (Int.toString (Real.round (rad2deg (meanAngle rads))))
val _ = print "\n"
in
doAngleMeans rest
end

30
Task/Averages-Mean-angle/Yabasic/averages-mean-angle.basic Normal file
View file

@ -0,0 +1,30 @@
dim angles1(2)
angles1(1) = 350
angles1(2) = 10
dim angles2(4)
angles2(1) = 90
angles2(2) = 180
angles2(3) = 270
angles2(4) = 360
dim angles3(3)
angles3(1) = 10
angles3(2) = 20
angles3(3) = 30
print "Mean for angles 1 is : ", MeanAngle(angles1()) using ("####.##"), " degrees"
print "Mean for angles 2 is : ", MeanAngle(angles2()) using ("####.##"), " degrees"
print "Mean for angles 3 is : ", MeanAngle(angles3()) using ("####.##"), " degrees"
end
sub MeanAngle(angles())
length = arraysize(angles(), 1) + 1
sinSum = 0.0
cosSum = 0.0
for i = 1 to arraysize(angles(), 1)
sinSum = sinSum + sin(angles(i) * PI / 180.0)
cosSum = cosSum + cos(angles(i) * PI / 180.0)
next
return atan(sinSum / length, cosSum / length) * 180.0 / PI
end sub

19
Task/Averages-Root-mean-square/FutureBasic/averages-root-mean-square.basic Normal file
View file

@ -0,0 +1,19 @@
double local fn QuadraticMean( array as CFArrayRef )
long count = len(array)
double sum = 0.0
for long i = 0 to count - 1
sum += dblval(array[i]) * dblval(array[i])
next
end fn = sqr(sum/count)
void local fn DoIt
CFMutableArrayRef array = fn MutableArrayNew
for long i = 1 to 10
MutableArrayAddObject( array, @(i) )
next
print @"RMS (1-10) = ";fn QuadraticMean(array)
end fn
fn DoIt
HandleEvents

32
Task/Averages-Simple-moving-average/Standard-ML/averages-simple-moving-average.ml Normal file
View file

@ -0,0 +1,32 @@
(* helper functions *)
val sum = List.foldl (op +) 0.0
fun mean xs = (sum xs) / (Real.fromInt (length xs))
type smastate = int * real list
(* initialize an SMA state with the given period *)
fun smaInit period : smastate = (period, [])
(* update the SMA in the given state with the given number *)
(* returns a tuple containing the new SMA and the new state *)
fun sma (state : smastate) (num : real) : (real * smastate) =
let
val (period, buffer) = state
val amt = Int.min(1 + List.length buffer, period)
val newlist = List.take(num::buffer, amt)
in
(mean newlist, (period, newlist))
end
fun printSMA' _ [] = ()
| printSMA' state (x::xs) =
let
val (n, next) = sma state x
in
print ("Added " ^ (Real.toString x) ^ ": SMA=" ^ (Real.toString n) ^ "\n");
printSMA' next xs
end
(* print the SMA with given period at each step over the list xs *)
fun printSMA period xs =
printSMA' (smaInit period) xs

136
Task/Babylonian-spiral/Ada/babylonian-spiral.ada Normal file
View file

@ -0,0 +1,136 @@
pragma Ada_2022;
with Ada.Containers.Vectors;
with Ada.Numerics; use Ada.Numerics;
with Ada.Numerics.Elementary_Functions; use Ada.Numerics.Elementary_Functions;
with Ada.Text_IO; use Ada.Text_IO;
procedure Babylonian_Spiral is
type Fixed_10_4 is delta 10.0 ** (-4) digits 9;
type Point is record
X, Y : Integer;
end record;
type Points_Array is array (1 .. 10_000) of Point;
Points : Points_Array := [1 => (0, 0), 2 => (0, 1), others => (0, 0)];
Ante_Previous_Point, Previous_Point : Point;
package Point_Vectors is new Ada.Containers.Vectors (Positive, Point);
use Point_Vectors;
Point_Vector, PVC : Point_Vectors.Vector;
Min_Radius : Integer := 1;
Previous_Dist : Fixed_10_4; -- The previous distance which must be exceeded
Min_Dist, Tmp_Dist : Fixed_10_4;
Max_Angle, Tmp_Angle : Fixed_10_4;
Tmp_Ix, Cand_Ix : Integer;
Fixed_Pi : constant Fixed_10_4 := 3.1416;
SVG_File : File_Type;
X, Y : Integer;
function Distance (Point1, Point2 : Point) return Fixed_10_4 is
(Fixed_10_4 (Sqrt (Float (Point2.X - Point1.X)**2 +
Float (Point2.Y - Point1.Y)**2)));
function Generate_Square_Of_Points (Centre : Point; Max_Radius : Positive)
return Point_Vectors.Vector is
PV : Point_Vectors.Vector;
begin
for X in Centre.X - Max_Radius .. Centre.X + Max_Radius loop
for Y in Centre.Y - Max_Radius .. Centre.Y + Max_Radius loop
PV.Append ((X, Y), 1);
end loop;
end loop;
return PV;
end Generate_Square_Of_Points;
function Atan2 (Y, X : Float) return Float is
Res : Float;
begin
if X > 0.0 then Res := Arctan (Y / X);
elsif X < 0.0 and then Y >= 0.0 then Res := Arctan (Y / X) + Pi;
elsif X < 0.0 and then Y < 0.0 then Res := Arctan (Y / X) - Pi;
elsif X = 0.0 and then Y > 0.0 then Res := Pi / 2.0;
elsif X = 0.0 and then Y > 0.0 then Res := -Pi / 2.0;
else Res := -Pi / 2.0; -- Technically: Undefined
end if;
return Res;
end Atan2;
function Angle (Centre, P2, P3 : Point) return Fixed_10_4 is
Res : Float;
begin
Res := Atan2 (Float (P3.Y) - Float (Centre.Y), Float (P3.X) - Float (Centre.X)) -
Atan2 (Float (P2.Y) - Float (Centre.Y), Float (P2.X) - Float (Centre.X));
return Fixed_10_4 (Res);
end Angle;
function Collinear (Pt1, Pt2, Pt3 : Point) return Boolean is
begin
if Pt1.X = Pt2.X and then Pt2.X = Pt3.X then
return True;
end if;
if Pt1.Y = Pt2.Y and then Pt2.Y = Pt3.Y then
return True;
end if;
return Pt1.X * (Pt2.Y - Pt3.Y) + Pt2.X * (Pt3.Y - Pt1.Y) + Pt3.X * (Pt1.Y - Pt2.Y) = 0;
end Collinear;
begin
for Point_Ix in 3 .. Points'Last loop
Ante_Previous_Point := Points (Point_Ix - 2);
Previous_Point := Points (Point_Ix - 1);
Previous_Dist := Distance (Points (Point_Ix - 1), Points (Point_Ix - 2));
Min_Radius := Integer (Previous_Dist);
Min_Dist := 99999.999;
Max_Angle := 0.0;
-- examine surrounding points
Point_Vector := Generate_Square_Of_Points (Previous_Point, Min_Radius + 4);
for Pt of Point_Vector loop
if not Collinear (Pt, Previous_Point, Ante_Previous_Point) then
Tmp_Dist := Distance (Pt, Previous_Point);
if Tmp_Dist > Previous_Dist and then Tmp_Dist < Min_Dist then
Min_Dist := Tmp_Dist;
end if;
end if;
end loop;
-- Grab closest Points
PVC.Clear;
for Pt of Point_Vector loop
if Distance (Pt, Previous_Point) = Min_Dist then
PVC.Append (Pt);
end if;
end loop;
Tmp_Ix := 1;
for Pt of PVC loop
Tmp_Angle := Angle (Previous_Point, Ante_Previous_Point, Pt);
if Tmp_Angle < -(Fixed_Pi) then
Tmp_Angle := Tmp_Angle + (2.0 * Fixed_Pi);
end if;
if Tmp_Angle < Fixed_Pi and then Tmp_Angle > Max_Angle then
Cand_Ix := Tmp_Ix;
Max_Angle := Tmp_Angle;
end if;
Tmp_Ix := Tmp_Ix + 1;
end loop;
if Point_Ix < 41 then
Put ("(" & PVC (Cand_Ix).X'Image & "," & PVC (Cand_Ix).Y'Image & ") ");
end if;
Points (Point_Ix) := PVC (Cand_Ix);
end loop;
Create (SVG_File, Out_File, "babylonian_spiral.svg");
Put_Line (SVG_File, "<svg xmlns='http://www.w3.org/2000/svg' width='12000' height='15000'>");
Put_Line (SVG_File, "<rect width='100%' height='100%' fill='white'/>");
X := 500 + Points (1).X;
Y := 10000 - Points (1).Y;
Put (SVG_File, "<path stroke-width='2' stroke='black' fill='none' d='M" &
X'Image & "," & Y'Image);
for Pt_Ix in 2 .. Points'Last loop
X := 500 + Points (Pt_Ix).X;
Y := 10000 - Points (Pt_Ix).Y;
Put (SVG_File, " L" & X'Image & "," & Y'Image);
end loop;
Put_Line (SVG_File, "'/>\n</svg>");
Close (SVG_File);
end Babylonian_Spiral;

80
Task/Babylonian-spiral/M2000-Interpreter/babylonian-spiral.m2000 Normal file
View file

@ -0,0 +1,80 @@
module Babylonian_spiral (max=40) {
declare math math
const TAU=6.283185307179586
dim sq()
sq()=lambda (m)-> {
for i=0 to m-1:data i*i:next
=array([])
}(max)
xydeltas=((0&, 0&), (0&, 1&))
def isqrt(n)=val(sqrt(n)->long)
def pr(c)="("+c#str$(", ")+")"
long δsquared = 1
for L=0 to max-3
(x,y)=xydeltas#val(len(xydeltas)-1)
θ = @atan2(y, x)
candidates=stack
while len(candidates)=0
δsquared++
for i=0& to max-1
a=sq(i)
if a > δsquared/2& then exit for
for j =isqrt(δsquared) + 1 to 1
b = sq(j)
if a + b < δsquared then exit for
if a + b = δsquared then
stack candidates {
Data (i, j), (-i, j), (i, -j), (-i, -j), (j, i), (-j, i), (j, -i), (-j, -i)
}
end if
next
next
end while
minimum=(,)
minVal=TAU
stack candidates {
while not empty
read candidate()
val = (θ - @atan2(candidate(1), candidate(0))) mod# TAU
if val < minVal then minVal = val : minimum = candidate()
end while
}
append xyDeltas, (minimum,)
next
for i=0 to len(xyDeltas)-2
Return xyDeltas, i+1:=@add(xyDeltas#val(i+1), xyDeltas#val(i))
next
Drawing 12000, 12000 {
Cls, 0
pen 0
(m1, m2, s1)=(6000, 6000, twipsX*10)
move m1, m2
k=each(xyDeltas)
dim b()
while k
b()=array(k)
b=b()
b*=s1
draw to b(0)+m1, m2-b(1): circle fill 1, 30
end while
} as Drw
image drw
clipboard drw as "emf"
Document Doc$
for i=0 to len(xyDeltas)-2
Doc$=pr(xyDeltas#val(i))+", "
next
Doc$=pr(xyDeltas#val(i))
Print Doc$
Save.Doc Doc$, "out.txt"
function add(a(), b())
=a(0)+b(0), a(1)+b(1)
end function
function atan2(y, x)
method math, "atan2", y, x as ret
=ret // radians
end function
}
Babylonian_spiral 40

34
Task/Barnsley-fern/FutureBasic/barnsley-fern.basic Normal file
View file

@ -0,0 +1,34 @@
void local fn BarnsleyFern( height as long )
double x = 0, y = 0, xn, yn, f = height / 10.6
long n, r, offsetX = height / 4 - height / 40
for n = 1 to height * 50
r = rnd(100) - 1
select
case r >= 0 && r <= 84
xn = 0.85 * x + 0.04 * y
yn = -0.04 * x + 0.85 * y + 1.6
case r >= 85 && r <= 91
xn = 0.2 * x - 0.26 * y
yn = 0.23 * x + 0.22 * y + 1.6
case r >= 92 && r <= 98
xn = -0.15 * x + 0.28 * y
yn = 0.26 * x + 0.24 * y + 0.44
case else
xn = 0
yn = 0.16 * y
end select
x = xn : y = yn
pen -1
oval fill (offsetX + x * f, height - y * f, 1.5, 1.5), _zGreen
next
end fn
window 1, @"Barnsley fern", (0,0,300,600)
WindowSetBackgroundColor( 1, fn ColorBlack )
fn BarnsleyFern( 600 )
HandleEvents

373
Task/Bernoulli-numbers/Isabelle/bernoulli-numbers-1.isabelle Normal file
View file

@ -0,0 +1,373 @@
theory Mini_Bernoulli
imports Complex_Main
"HOL-Computational_Algebra.Computational_Algebra"
"HOL-Combinatorics.Stirling"
"HOL-Library.Stream"
"Coinductive.Coinductive_List"
"HOL-Library.Code_Target_Numeral"
"HOL-Library.Code_Lazy"
begin
subsection ‹Definition of Bernoulli numbers›
(* We define Bernoulli numbers in the standard fashion as those numbers B_n whose exponential
generating function function is X / (1 - e^(-X)): *)
definition bernoulli_fps :: "rat fps"
where "bernoulli_fps = fps_X / (1 - fps_exp (-1))"
definition bernoulli :: "nat ⇒ rat" where
"bernoulli n = fps_nth bernoulli_fps n * fact n"
subsection ‹Stirling numbers of the 2nd kind›
(* We use the Stirling numbers from the Isabelle library and prove a few additional things
about them. *)
lemma Stirling_n_0: "Stirling n 0 = (if n = 0 then 1 else 0)"
by (cases n) simp_all
lemma sum_Stirling_binomial:
"Stirling (Suc n) (Suc m) = (∑i=0..n. Stirling i m * (n choose i))"
proof -
have "real (Stirling (Suc n) (Suc m)) = real (∑i = 0..n. Stirling i m * (n choose i))"
proof (induction n arbitrary: m)
case (Suc n m)
have "real (∑i = 0..Suc n. Stirling i m * (Suc n choose i)) =
real (∑i = 0..n. Stirling (Suc i) m * (Suc n choose Suc i)) + real (Stirling 0 m)"
by (subst sum.atLeast0_atMost_Suc_shift) simp_all
also have "real (∑i = 0..n. Stirling (Suc i) m * (Suc n choose Suc i)) =
real (∑i = 0..n. (n choose i) * Stirling (Suc i) m) +
real (∑i = 0..n. (n choose Suc i) * Stirling (Suc i) m)"
by (simp add: algebra_simps sum.distrib)
also have "(∑i = 0..n. (n choose Suc i) * Stirling (Suc i) m) =
(∑i = Suc 0..Suc n. (n choose i) * Stirling i m)"
by (subst sum.shift_bounds_cl_Suc_ivl) simp_all
also have "… = (∑i = Suc 0..n. (n choose i) * Stirling i m)"
by (intro sum.mono_neutral_right) auto
also have "… = real (∑i = 0..n. Stirling i m * (n choose i)) - real (Stirling 0 m)"
by (simp add: sum.atLeast_Suc_atMost mult_ac)
also have "real (∑i = 0..n. Stirling i m * (n choose i)) = real (Stirling (Suc n) (Suc m))"
by (rule Suc.IH [symmetric])
also have "real (∑i = 0..n. (n choose i) * Stirling (Suc i) m) =
real m * real (Stirling (Suc n) (Suc m)) + real (Stirling (Suc n) m)"
by (cases m; (simp only: Suc.IH, simp add: algebra_simps sum.distrib
sum_distrib_left sum_distrib_right))
also have "… + (real (Stirling (Suc n) (Suc m)) - real (Stirling 0 m)) + real (Stirling 0 m) =
real (Suc m * Stirling (Suc n) (Suc m) + Stirling (Suc n) m)"
by (simp add: algebra_simps del: Stirling.simps)
also have "Suc m * Stirling (Suc n) (Suc m) + Stirling (Suc n) m =
Stirling (Suc (Suc n)) (Suc m)"
by (rule Stirling.simps(4) [symmetric])
finally show ?case ..
qed simp_all
thus ?thesis by (subst (asm) of_nat_eq_iff)
qed
(* The exponential generating function of the Stirling numbers (of the 2nd kind) with
fixed second argument $m$ is S_m(X) = (e^X - 1)^m / m!.
We use this fact to derive a closed form for them. *)
lemma Stirling_fps_aux:
"(fps_exp 1 - 1) ^ m $ n * fact n = (fact m * of_nat (Stirling n m) :: 'a :: field_char_0)"
proof (induction m arbitrary: n)
case 0
thus ?case by (simp add: Stirling_n_0)
next
case (Suc m n)
show ?case
proof (cases n)
case 0
thus ?thesis by simp
next
case (Suc n')
hence "(fps_exp 1 - 1 :: 'a fps) ^ Suc m $ n * fact n =
fps_deriv ((fps_exp 1 - 1) ^ Suc m) $ n' * fact n'"
by (simp_all add: algebra_simps del: power_Suc)
also have "fps_deriv ((fps_exp 1 - 1 :: 'a fps) ^ Suc m) =
fps_const (of_nat (Suc m)) * ((fps_exp 1 - 1) ^ m * fps_exp 1)"
by (subst fps_deriv_power) simp_all
also have "… $ n' * fact n' =
of_nat (Suc m) * ((∑i = 0..n'. (fps_exp 1 - 1) ^ m $ i / fact (n' - i)) * fact n')"
unfolding fps_mult_left_const_nth
by (simp add: fps_mult_nth Suc.IH sum_distrib_right del: of_nat_Suc)
also have "(∑i = 0..n'. (fps_exp 1 - 1 :: 'a fps) ^ m $ i / fact (n' - i)) * fact n' =
(∑i = 0..n'. (fps_exp 1 - 1) ^ m $ i * fact n' / fact (n' - i))"
by (subst sum_distrib_right, rule sum.cong) (simp_all add: divide_simps)
also have "… = (∑i = 0..n'. (fps_exp 1 - 1) ^ m $ i * fact i * of_nat (n' choose i))"
by (intro sum.cong refl) (simp_all add: binomial_fact)
also have "… = (∑i = 0..n'. fact m * of_nat (Stirling i m) * of_nat (n' choose i))"
by (simp only: Suc.IH)
also have "of_nat (Suc m) * … = (fact (Suc m) :: 'a) *
(∑i = 0..n'. of_nat (Stirling i m) * of_nat (n' choose i))" (is "_ = _ * ?S")
by (simp add: sum_distrib_left sum_distrib_right mult_ac del: of_nat_Suc)
also have "?S = of_nat (Stirling (Suc n') (Suc m))"
by (subst sum_Stirling_binomial) simp
also have "Suc n' = n" by (simp add: Suc)
finally show ?thesis .
qed
qed
theorem Stirling_closed_form:
"(of_nat (Stirling n k) :: 'a :: field_char_0) =
(∑j≤k. (-1)^(k - j) * of_nat (k choose j) * of_nat j ^ n) / fact k"
proof -
have "(fps_exp 1 - 1 :: 'a fps) = (fps_exp 1 + (-1))" by simp
also have "… ^ k = (∑j≤k. of_nat (k choose j) * fps_exp 1 ^ j * (- 1) ^ (k - j))"
unfolding binomial_ring ..
also have "… = (∑j≤k. fps_const ((-1) ^ (k - j) * of_nat (k choose j)) * fps_exp (of_nat j))"
by (simp add: fps_const_mult [symmetric] fps_const_power [symmetric]
fps_const_neg [symmetric] mult_ac fps_of_nat fps_exp_power_mult
del: fps_const_mult fps_const_power fps_const_neg)
also have "fps_nth … n = (∑j≤k. (- 1) ^ (k - j) * of_nat (k choose j) * of_nat j ^ n) / fact n"
by (simp add: fps_sum_nth sum_divide_distrib)
also have "… * fact n = (∑j≤k. (- 1) ^ (k - j) * of_nat (k choose j) * of_nat j ^ n)"
by simp
also note Stirling_fps_aux[of k n]
finally show ?thesis by (simp add: atLeast0AtMost field_simps)
qed
(*
We now define a somewhat ad-hoc operator formal power series: XD' maps a formal power
series A(X) to the series (X - 1) A'(X).
The relevance of this operator to us is that the n-fold iteration of this operator
is related to Stirling numbers.
*)
definition fps_XD' :: "'a :: field_char_0 fps ⇒ 'a fps"
where "fps_XD' = (λb. (fps_X - 1) * fps_deriv b)"
lemma fps_XD'_0 [simp]: "fps_XD' 0 = 0"
and fps_XD'_1 [simp]: "fps_XD' 1 = 0"
and fps_XD'_add [simp]: "fps_XD' (b + c) = fps_XD' b + fps_XD' c"
and fps_XD'_mult: "fps_XD' (b * c) = fps_XD' b * c + b * fps_XD' c"
by (simp_all add: fps_XD'_def algebra_simps)
lemma fps_XD'_power: "fps_XD' (b ^ n) = of_nat n * b ^ (n - 1) * fps_XD' b"
by (induction n) (simp_all add: algebra_simps fps_XD'_mult power_eq_if)
lemma fps_XD'_sum: "fps_XD' (sum f A) = sum (λx. fps_XD' (f x)) A"
by (induction A rule: infinite_finite_induct) simp_all
lemma fps_XD'_funpow:
defines "S ≡ λn i. fps_const (of_nat (Stirling n i))"
shows "(fps_XD' ^^ n) H = (∑m≤n. S n m * (fps_X - 1) ^ m * (fps_deriv ^^ m) H)"
proof (induction n arbitrary: H)
case 0
thus ?case by (simp add: S_def)
next
case (Suc n H)
define G where "G = (fps_X - 1 :: 'a fps)"
have "(∑m≤Suc n. S (Suc n) m * G ^ m * (fps_deriv ^^ m) H) =
(∑i≤n. of_nat (Suc i) * S n (Suc i) * G ^ Suc i * (fps_deriv ^^ Suc i) H) +
(∑i≤n. S n i * G ^ Suc i * (fps_deriv ^^ Suc i) H)"
(is "_ = sum (λi. ?f (Suc i)) … + ?S2")
by (subst sum.atMost_Suc_shift) (simp_all add: sum.distrib algebra_simps fps_of_nat S_def
fps_const_add [symmetric] fps_const_mult [symmetric] del: fps_const_add fps_const_mult)
also have "sum (λi. ?f (Suc i)) {..n} = sum (λi. ?f (Suc i)) {..<n}"
by (intro sum.mono_neutral_right) (auto simp: S_def)
also have "… = ?f 0 + …" by simp
also have "… = sum ?f {..n}" by (subst sum.atMost_shift [symmetric]) simp_all
also have "… + ?S2 = (∑x≤n. fps_XD' (S n x * G ^ x * (fps_deriv ^^ x) H))"
unfolding sum.distrib [symmetric]
proof (rule sum.cong, goal_cases)
case (2 i)
thus ?case unfolding fps_XD'_mult fps_XD'_power
by (cases i) (auto simp: fps_XD'_mult algebra_simps of_nat_diff S_def fps_XD'_def G_def)
qed simp_all
also have "… = (fps_XD' ^^ Suc n) H" by (simp add: Suc.IH fps_XD'_sum G_def)
finally show ?case by (simp add: G_def)
qed
subsection ‹The Akiyama–Tanigawa transform›
(* a single step in the Akiyama–Tanigawa matrix, i.e. how to get the next
line from the current one *)
definition AT_step :: "(nat ⇒ 'a :: field_char_0) ⇒ nat ⇒ 'a"
where "AT_step f = (λk. of_nat (k+1) * (f k - f (k+1)))"
definition AT_matrix :: "(nat ⇒ 'a :: field_char_0) ⇒ nat ⇒ nat ⇒ 'a" where
"AT_matrix f n = (AT_step ^^ n) f"
(* The following describes the ordinary generating function of the n-th row in the AT matrix. *)
definition AT_fps :: "(nat ⇒ 'a :: field_char_0) ⇒ nat ⇒ 'a fps" where
"AT_fps f n = (fps_X - 1) * Abs_fps (AT_matrix f n)"
lemma AT_fps_Suc: "AT_fps f (Suc n) = (fps_X - 1) * fps_deriv (AT_fps f n)"
proof (rule fps_ext)
fix m :: nat
show "AT_fps f (Suc n) $ m = ((fps_X - 1) * fps_deriv (AT_fps f n)) $ m"
by (cases m) (simp_all add: AT_fps_def AT_matrix_def AT_step_def fps_deriv_def algebra_simps)
qed
lemma AT_fps_altdef:
"AT_fps f n =
(∑m≤n. fps_const (of_nat (Stirling n m)) * (fps_X - 1)^m * (fps_deriv ^^ m) (AT_fps f 0))"
proof -
have "AT_fps f n = (fps_XD' ^^ n) (AT_fps f 0)"
by (induction n) (simp_all add: AT_fps_Suc fps_XD'_def)
also have "… = (∑m≤n. fps_const (of_nat (Stirling n m)) * (fps_X - 1) ^ m *
(fps_deriv ^^ m) (AT_fps f 0))"
by (rule fps_XD'_funpow)
finally show ?thesis .
qed
lemma AT_fps_0_nth: "AT_fps f 0 $ n = (if n = 0 then -f 0 else f (n - 1) - f n)"
by (simp add: AT_fps_def AT_matrix_def algebra_simps)
(* The following gives a closed form for the first column of the AT matrix, i.e. the
result of the transform. *)
lemma AT_matrix_firstcol:
"AT_matrix f n 0 = (∑k≤n. (-1) ^ k * fact k * of_nat (Stirling (Suc n) (Suc k)) * f k)"
proof (cases "n = 0")
case False
have "AT_matrix f n 0 = -(AT_fps f n $ 0)" by (simp add: AT_fps_def)
also have "AT_fps f n $ 0 =
(∑k≤n. of_nat (Stirling n k) * (- 1) ^ k * (fact k * AT_fps f 0 $ k))"
by (subst AT_fps_altdef) (simp add: fps_sum_nth fps_nth_power_0 fps_0th_higher_deriv)
also have "… = (∑k≤n. of_nat (Stirling n k) * (- 1) ^ k * (fact k * (f (k - 1) - f k)))"
using False by (intro sum.cong refl) (auto simp: Stirling_n_0 AT_fps_0_nth)
also have "… = (∑k≤n. fact k * (of_nat (Stirling n k) * (- 1) ^ k) * f (k - 1)) -
(∑k≤n. fact k * (of_nat (Stirling n k) * (- 1) ^ k) * f k)"
(is "_ = sum ?f _ - ?S2") by (simp add: sum_subtractf algebra_simps)
also from False have "sum ?f {..n} = sum ?f {0<..n}"
by (intro sum.mono_neutral_right) (auto simp: Stirling_n_0)
also have "… = sum ?f {0<..Suc n}"
by (intro sum.mono_neutral_left) auto
also have "{0<..Suc n} = {Suc 0..Suc n}" by auto
also have "sum ?f … = sum (λn. ?f (Suc n)) {0..n}"
by (subst sum.atLeast_Suc_atMost_Suc_shift) simp_all
also have "{0..n} = {..n}" by auto
also have "sum (λn. ?f (Suc n)) … - ?S2 =
(∑k≤n. -((-1)^k * fact k * of_nat (Stirling (Suc n) (Suc k)) * f k))"
by (subst sum_subtractf [symmetric], intro sum.cong) (simp_all add: algebra_simps)
also have "-… = (∑k≤n. ((-1)^k * fact k * of_nat (Stirling (Suc n) (Suc k)) * f k))"
by (simp add: sum_negf)
finally show ?thesis .
qed (simp_all add: AT_matrix_def)
(* The following theorem relates the exponential generating function B(X) of the transformed
sequence to the ordinary generating function A(X) of the original sequence.
Namely: B(X) = e^X A(1 - e^X). *)
theorem AT_fps:
"Abs_fps (λn. AT_matrix f n 0 / fact n) = fps_exp 1 * fps_compose (Abs_fps f) (1 - fps_exp 1)"
proof (rule fps_ext)
fix n :: nat
have "(fps_const (fact n) *
(fps_compose (Abs_fps (λn. AT_matrix f 0 n)) (1 - fps_exp 1) * fps_exp 1)) $ n =
(∑m≤n. ∑k≤m. (1 - fps_exp 1) ^ k $ m * fact n / fact (n - m) * f k)"
unfolding fps_mult_left_const_nth
by (simp add: fps_times_def fps_compose_def AT_matrix_firstcol sum_Stirling_binomial
field_simps sum_distrib_left sum_distrib_right atLeast0AtMost AT_matrix_def
del: Stirling.simps of_nat_Suc)
also have "… = (∑m≤n. ∑k≤m. (-1)^k * fact k * of_nat (Stirling m k * (n choose m)) * f k)"
proof (intro sum.cong refl, goal_cases)
case (1 m k)
have "(1 - fps_exp 1 :: 'a fps) ^ k = (-fps_exp 1 + 1 :: 'a fps) ^ k" by simp
also have "… = (∑i≤k. of_nat (k choose i) * (-1) ^ i * fps_exp (of_nat i))"
by (subst binomial_ring) (simp add: atLeast0AtMost power_minus' fps_exp_power_mult mult.assoc)
also have "… = (∑i≤k. fps_const (of_nat (k choose i) * (-1) ^ i) * fps_exp (of_nat i))"
by (simp add: fps_const_mult [symmetric] fps_of_nat fps_const_power [symmetric]
fps_const_neg [symmetric] del: fps_const_mult fps_const_power fps_const_neg)
also have "… $ m = (∑i≤k. of_nat (k choose i) * (- 1) ^ i * of_nat i ^ m) / fact m"
(is "_ = ?S / _") by (simp add: fps_sum_nth sum_divide_distrib [symmetric])
also have "?S = (-1) ^ k * (∑i≤k. (-1) ^ (k - i) * of_nat (k choose i) * of_nat i ^ m)"
by (subst sum_distrib_left, intro sum.cong refl) (auto simp: minus_one_power_iff)
also have "(∑i≤k. (-1) ^ (k - i) * of_nat (k choose i) * of_nat i ^ m) =
of_nat (Stirling m k) * (fact k :: 'a)"
by (subst Stirling_closed_form) (simp_all add: field_simps)
finally have *: "(1 - fps_exp 1 :: 'a fps) ^ k $ m * fact n / fact (n - m) =
(- 1) ^ k * fact k * of_nat (Stirling m k) * of_nat (n choose m)"
using 1 by (simp add: binomial_fact del: of_nat_Suc)
show ?case using 1 by (subst *) simp
qed
also have "… = (∑m≤n. ∑k≤n. (- 1) ^ k * fact k *
of_nat (Stirling m k * (n choose m)) * f k)"
by (rule sum.cong[OF refl], rule sum.mono_neutral_left) auto
also have "… = (∑k≤n. ∑m≤n. (- 1) ^ k * fact k *
of_nat (Stirling m k * (n choose m)) * f k)"
by (rule sum.swap)
also have "… = AT_matrix f n 0"
by (simp add: AT_matrix_firstcol sum_Stirling_binomial sum_distrib_left sum_distrib_right
mult.assoc atLeast0AtMost del: Stirling.simps)
finally show "Abs_fps (λn. AT_matrix f n 0 / fact n) $ n =
(fps_exp 1 * (Abs_fps f oo 1 - fps_exp 1)) $ n"
by (subst (asm) fps_mult_left_const_nth) (simp add: field_simps AT_matrix_def del: of_nat_Suc)
qed
(* If we specialise this to the input sequence a(k) = 1 / (k+1), this has the ordinary
generating function -ln(1 - X) / X, so the exponential generating function of the
AT transform is e^X (-ln (1 - (1 - e^X)) / (1 - e^X)) = X / (1 - e^(-X)),
which is exactly the exponential generating function of the Bernoulli numbers. *)
corollary bernoulli_conv_AT: "bernoulli n = AT_matrix (λk. 1 / of_nat (k+1)) n 0"
proof -
define f :: "nat ⇒ rat" where "f = (λn. 1 / of_nat (Suc n))"
note AT_fps[of f]
also {
have "fps_ln 1 = fps_X * Abs_fps (λn. (-1)^n / of_nat (Suc n) :: rat)"
by (intro fps_ext) (simp del: of_nat_Suc add: fps_ln_def)
hence "fps_ln 1 / fps_X = Abs_fps (λn. (-1)^n / of_nat (Suc n) :: rat)"
by (metis fps_X_neq_zero nonzero_mult_div_cancel_left)
also have "fps_compose … (-fps_X) = Abs_fps f"
by (simp add: fps_compose_uminus' fps_eq_iff f_def)
finally have "Abs_fps f = fps_compose (fps_ln 1 / fps_X) (-fps_X)" ..
also have "fps_ln 1 / fps_X oo - fps_X oo 1 - fps_exp (1::rat) = fps_ln 1 / fps_X oo fps_exp 1 - 1"
by (subst fps_compose_assoc [symmetric])
(simp_all add: fps_compose_uminus)
also have "… = (fps_ln 1 oo fps_exp 1 - 1) / (fps_exp 1 - 1)"
by (subst fps_compose_divide_distrib) auto
also have "… = fps_X / (fps_exp 1 - 1)" by (simp add: fps_ln_fps_exp_inv fps_inv_fps_exp_compose)
finally have "Abs_fps f oo 1 - fps_exp 1 = fps_X / (fps_exp 1 - 1)" .
}
also have "fps_exp (1::rat) - 1 = (1 - fps_exp (-1)) * fps_exp 1"
by (simp add: algebra_simps fps_exp_add_mult [symmetric])
also have "fps_exp 1 * (fps_X / …) = bernoulli_fps" unfolding bernoulli_fps_def
by (subst dvd_div_mult2_eq) (auto simp: fps_dvd_iff intro!: subdegree_leI)
finally have "Abs_fps (λn. AT_matrix f n 0 / fact n) = bernoulli_fps" .
hence "fps_nth (Abs_fps (λn. AT_matrix f n 0 / fact n)) n = fps_nth bernoulli_fps n"
by (rule arg_cong)
thus ?thesis by (simp add: fps_eq_iff f_def bernoulli_def field_simps)
qed
subsection ‹Efficient code›
(* Next, we implement the AT transform using infinite streams. We define the infinite
AT matrix as a stream of streams of numbers and then define its leftmost column as the
result of the transform. *)
primcorec AT_impl_step :: "nat ⇒ 'a :: field_char_0 stream ⇒ 'a stream" where
"AT_impl_step m xs =
of_nat m * (xs !! 0 - xs !! 1) ## AT_impl_step (Suc m) (stl xs)"
primcorec AT_matrix_impl :: "'a :: field_char_0 stream ⇒ 'a stream stream" where
"AT_matrix_impl xs = xs ## AT_matrix_impl (AT_impl_step 1 xs)"
definition AT_impl :: "'a :: field_char_0 stream ⇒ 'a :: field_char_0 stream" where
"AT_impl xs = smap shd (AT_matrix_impl xs)"
lemma snth_AT_impl_step [simp]:
"AT_impl_step m xs !! n = of_nat (m + n) * (xs !! n - xs !! (n+1))"
by (induction n arbitrary: m xs; subst AT_impl_step.code) auto
lemma snth_AT_matrix_impl [simp]: "AT_matrix_impl xs !! n !! k = AT_matrix (snth xs) n k"
by (induction n arbitrary: xs k; subst AT_matrix_impl.code)
(auto simp: snth_AT_impl_step [abs_def] AT_matrix_def funpow_Suc_right AT_step_def
simp del: funpow.simps of_nat_Suc)
lemma snth_AT_impl [simp]: "AT_impl xs !! n = AT_matrix (snth xs) n 0"
by (simp add: AT_impl_def flip: snth.simps(1))
definition bernoulli_stream :: "rat stream" where
"bernoulli_stream = AT_impl (smap (λi. 1 / of_nat i) (fromN 1))"
theorem bernoulli_stream_correct: "bernoulli_stream !! n = bernoulli n"
by (simp add: bernoulli_stream_def bernoulli_conv_AT snth_smap [abs_def])
end

45
Task/Bernoulli-numbers/Isabelle/bernoulli-numbers-2.isabelle Normal file
View file

@ -0,0 +1,45 @@
code_lazy_type stream
code_lazy_type llist
primcorec llist_of_stream :: "'a stream ⇒ 'a llist" where
"llist_of_stream xs = LCons (shd xs) (llist_of_stream (stl xs))"
value "list_of (ltakeWhile (λ(i,_). i ≤ 60)
(llist_of_stream (sfilter (λ(_, x). x ≠ 0)
(szip (fromN 0) bernoulli_stream))))"
(* Output
"[(0, 1),
(1, 1 / 2),
(2, 1 / 6),
(4, - (1 / 30)),
(6, 1 / 42),
(8, - (1 / 30)),
(10, 5 / 66),
(12, - (691 / 2730)),
(14, 7 / 6),
(16, - (3617 / 510)),
(18, 43867 / 798),
(20, - (174611 / 330)),
(22, 854513 / 138),
(24, - (236364091 / 2730)),
(26, 8553103 / 6),
(28, - (23749461029 / 870)),
(30, 8615841276005 / 14322),
(32, - (7709321041217 / 510)),
(34, 2577687858367 / 6),
(36, - (26315271553053477373 / 1919190)),
(38, 2929993913841559 / 6),
(40, - (261082718496449122051 / 13530)),
(42, 1520097643918070802691 / 1806),
(44, - (27833269579301024235023 / 690)),
(46, 596451111593912163277961 / 282),
(48, - (5609403368997817686249127547 / 46410)),
(50, 495057205241079648212477525 / 66),
(52, - (801165718135489957347924991853 / 1590)),
(54, 29149963634884862421418123812691 / 798),
(56, - (2479392929313226753685415739663229 / 870)),
(58, 84483613348880041862046775994036021 / 354),
(60, - (1215233140483755572040304994079820246041491 / 56786730))]"
:: "(nat × rat) list"
*)

96
Task/Bernoulli-numbers/M2000-Interpreter/bernoulli-numbers.m2000 Normal file
View file

@ -0,0 +1,96 @@
module Bernoulli_Numbers {
Class Rational {
numerator as decimal, denominator as decimal
gcd=lambda->0
lcm=lambda->0
operator "+" {
Read l
denom=.lcm(l.denominator, .denominator)
.numerator<=denom/l.denominator*l.numerator+denom/.denominator*.numerator
if .numerator==0 then denom=1
.denominator<=denom
}
Operator Unary {
.numerator-!
}
Operator "-" {
Read l
Call Operator "+", -l
}
Group Real {
value {
link parent numerator, denominator to n, d
=n/d
}
}
Group ToString$ {
value {
link parent numerator, denominator to n, d
=Str$(n)+"/"+Str$(d,"")
}
}
class:
Module Rational (.numerator, .denominator) {
if .denominator=0 then .denominator<=1
while frac(.numerator)<>0 {
.numerator*=10@
.denominator*=10@
}
sgn=Sgn(.numerator)*Sgn(.denominator)
.denominator<=abs(.denominator)
.numerator<=abs(.numerator)*sgn
gcd1=lambda (a as decimal, b as decimal) -> {
if a<b then swap a,b
g=a mod b
while g {
a=b:b=g: g=a mod b
}
=abs(b)
}
gdcval=gcd1(abs(.numerator), .denominator)
if gdcval<.denominator and gdcval<>0 then
.denominator/=gdcval
.numerator/=gdcval
end if
.gcd<=gcd1
.lcm<=lambda gcd=gcd1 (a as decimal, b as decimal) -> {
=a/gcd(a,b)*b
}
}
}
Open "out.txt" for output as #f
r1=Rational(1,1)
b=0
nextBern()
b=1
nextBern()
for b=2 to 28 step 2
nextBern()
next
close #f
sub nextBern()
local m=@bernoulli(b)
Print #F, format$("B({0::-2})={1}",b, m.tostring$)
end sub
function bernoulli(n as decimal)
Local a(1 to n+1)=Rational(1,1), z
local decimal m, j
for m=0 to n
a(m + 1) = Rational(1 , m + 1)
if m<1 then continue
for j = m to 1
z= a(J) - a(j+1) + r1
a(j)=z
nn=z.gcd(j, z.denominator)
a(j).numerator*=j/nn
a(j).denominator/=nn
next
for a(1) {
this=rational(.numerator, .denominator)
}
next
=a(1)
end function
}
Bernoulli_Numbers

75
Task/Binary-digits/LSL/binary-digits.lsl Normal file
View file

@ -0,0 +1,75 @@
/* This script could convert base10 to any base number system, & in any symbol-set
charset can be anything, any symbols, but the frist one should be the zero symbol */
string charset = "01";
string int2chr(integer int) {
// convert integer to unsigned charset
integer base = llStringLength(charset);
string out;
integer j;
if(int < 0) {
j = ((0x7FFFFFFF & int) % base) - (0x80000000 % base);
integer k = j % base;
int = (j / base) + ((0x7FFFFFFF & int) / base) - (0x80000000 / base);
out = llGetSubString(charset, k, k);
}
do
out = llGetSubString(charset, j = int % base, j) + out;
while(int /= base);
return out;
}
integer chr2int(string chr) {
// convert unsigned charset to integer
integer base = llStringLength(charset);
integer i = -llStringLength(chr);
integer j = 0;
while(i)
j = (j * base) + llSubStringIndex(charset, llGetSubString(chr, i, i++));
return j;
}
string pad (string input, integer width)
{
integer i=llStringLength(input);
string zero=llGetSubString(charset,0,0);
//first symbol of charset should be for zero
// add padding if necessary
while(width>i)
{
i=i+1;
input=zero+input; // prepend string and loop
}
// take away padding if necessary
while(width<i)
// do this if padding length is less than input
{ i=i-1;
if((llGetSubString(input, 0, 0))==zero)
{
// eat first leading bit if it's a zero symbol
input=llDeleteSubString(input,0,0);
//equivalent to input=llGetSubString(input,1,-1);
}
else{width=i;}
// to break loop stop if not a leading zero
}
return input;
}
default
{ // Default state is where script starts
state_entry()
{
integer a = 42;
llOwnerSay((string)a);
string output = int2chr(a); // dec to bin
llOwnerSay(output);
output=pad(output,10); // add padding
llOwnerSay(output);
output=pad(output,0); // take away padding
llOwnerSay(output);
llOwnerSay( (string)chr2int(output) ); // bin to dec
}
}

27
Task/Binary-search/FutureBasic/binary-search-1.basic Normal file
View file

@ -0,0 +1,27 @@
include "NSLog.incl"
NSInteger local fn BinarySearch( array as CFArrayRef, key as CFTypeRef )
NSInteger lo = 0
NSInteger hi = len(array) - 1
while ( lo <= hi )
NSInteger i = lo + (hi - lo) / 2
CFTypeRef midVal = array[i]
select ( fn NumberCompare( midVal, key ) )
case NSOrderedAscending
lo = i + 1
case NSOrderedDescending
hi = i - 1
case NSOrderedSame:
return i
end select
wend
end fn = NSNotFound
void local fn DoIt
CFArrayRef a = @[@1, @3, @4, @5, @6, @7, @8, @9, @10]
NSLog(@"6 is at position %d", fn BinarySearch( a, @6 ) ) // prints 4
end fn
fn DoIt
HandleEvents

28
Task/Binary-search/FutureBasic/binary-search-2.basic Normal file
View file

@ -0,0 +1,28 @@
include "NSLog.incl"
NSInteger local fn BinarySearch( array as CFArrayRef, key as CFTypeRef )
NSInteger lo = 0
include "NSLog.incl"
NSInteger local fn BinarySearch( array as CFArrayRef, key as CFTypeRef, range as CFRange )
if ( range.length == 0 ) then return NSNotFound
NSInteger i = range.location + range.length / 2
CFTypeRef midVal = array[i]
select ( fn NumberCompare( midVal, key ) )
case NSOrderedAscending
return fn BinarySearch( array, key, fn CFRangeMake( i + 1, range.length - i + 1 ) )
case NSOrderedDescending
return fn BinarySearch( array, key, fn CFRangeMake( range.location, i - range.location ) )
end select
end fn = i
void local fn DoIt
CFArrayRef a = @[@1, @3, @4, @5, @6, @7, @8, @9, @10]
NSLog(@"6 is at position %d", fn BinarySearch( a, @6, fn CFRangeMake(0,len(a)) )) // prints 4
end fn
fn DoIt
HandleEvents

112
Task/Bioinformatics-base-count/ALGOL-68/bioinformatics-base-count.alg
View file

@ -8,7 +8,7 @@ BEGIN # count DNA bases in a sequence #
[ 0 : 255 ]INT counts; # only counts ASCII characters #
FOR i FROM LWB counts TO UPB counts DO counts[ i ] := 0 OD;
FOR i FROM LWB results TO UPB results DO results[ i ] := 0 OD;
# count the occurrences of each ASCII character in s #
# count the occurances of each ASCII character in s #
FOR i FROM LWB s TO UPB s DO
IF INT ch pos = ABS s[ i ];
ch pos >= LWB counts AND ch pos <= UPB counts
@ -48,63 +48,67 @@ BEGIN # count DNA bases in a sequence #
FOR i FROM LWB results TO UPB results DO results[ i ] := 0 OD;
FOR i FROM LWB s TO UPB s DO
[]INT counts = s[ i ] COUNT c;
FOR i FROM LWB results TO UPB results DO
results[ i ] +:= counts[ i ]
FOR j FROM LWB results TO UPB results DO
results[ j ] +:= counts[ j ]
OD
OD;
results
END; # COUNT #
# returns the length of s #
OP LEN = ( STRING s )INT: ( UPB s - LWB s ) + 1;
# count the bases in the required sequence #
[]STRING seq = ( "CGTAAAAAATTACAACGTCCTTTGGCTATCTCTTAAACTCCTGCTAAATG"
, "CTCGTGCTTTCCAATTATGTAAGCGTTCCGAGACGGGGTGGTCGATTCTG"
, "AGGACAAAGGTCAAGATGGAGCGCATCGAACGCAATAAGGATCATTTGAT"
, "GGGACGTTTCGTCGACAAAGTCTTGTTTCGAGAGTAACGGCTACCGTCTT"
, "CGATTCTGCTTATAACACTATGTTCTTATGAAATGGATGTTCTGAGTTGG"
, "TCAGTCCCAATGTGCGGGGTTTCTTTTAGTACGTCGGGAGTGGTATTATA"
, "TTTAATTTTTCTATATAGCGATCTGTATTTAAGCAATTCATTTAGGTTAT"
, "CGCCGCGATGCTCGGTTCGGACCGCCAAGCATCTGGCTCCACTGCTAGTG"
, "TCCTAAATTTGAATGGCAAACACAAATAAGATTTAGCAATTCGTGTAGAC"
, "GACCGGGGACTTGCATGATGGGAGCAGCTTTGTTAAACTACGAACGTAAT"
);
STRING bases = "ATCG";
[]INT counts = seq COUNT bases;
# print the sequence with leading character positions #
# find the overall length of the sequence #
INT seq len := 0;
FOR i FROM LWB seq TO UPB seq DO
seq len +:= LEN seq[ i ]
OD;
# compute the minimum field width required for the positions #
INT s len := seq len;
INT width := 1;
WHILE s len >= 10 DO
width +:= 1;
s len OVERAB 10
OD;
# show the sequence #
print( ( "Sequence:", newline, newline ) );
INT start := 0;
FOR i FROM LWB seq TO UPB seq DO
print( ( " ", whole( start, - width ), " :", seq[ i ], newline ) );
start +:= LEN seq[ i ]
OD;
# show the base counts #
print( ( newline, "Bases: ", newline, newline ) );
INT total := 0;
FOR i FROM LWB bases TO UPB bases DO
print( ( " ", bases[ i ], " : ", whole( counts[ i ], - width ), newline ) );
total +:= counts[ i ]
OD;
# show the count of other characters (invalid bases) - if there are any #
IF INT others = UPB counts;
counts[ others ] /= 0
THEN
# there were characters other than the bases #
print( ( newline, "Other: ", whole( counts[ others ], - width ), newline, newline ) );
total +:= counts[ UPB counts ]
FI;
# totals #
print( ( newline, "Total: ", whole( total, - width ), newline ) )
BEGIN # task #
# count the bases in the required sequence #
[]STRING seq = ( "CGTAAAAAATTACAACGTCCTTTGGCTATCTCTTAAACTCCTGCTAAATG"
, "CTCGTGCTTTCCAATTATGTAAGCGTTCCGAGACGGGGTGGTCGATTCTG"
, "AGGACAAAGGTCAAGATGGAGCGCATCGAACGCAATAAGGATCATTTGAT"
, "GGGACGTTTCGTCGACAAAGTCTTGTTTCGAGAGTAACGGCTACCGTCTT"
, "CGATTCTGCTTATAACACTATGTTCTTATGAAATGGATGTTCTGAGTTGG"
, "TCAGTCCCAATGTGCGGGGTTTCTTTTAGTACGTCGGGAGTGGTATTATA"
, "TTTAATTTTTCTATATAGCGATCTGTATTTAAGCAATTCATTTAGGTTAT"
, "CGCCGCGATGCTCGGTTCGGACCGCCAAGCATCTGGCTCCACTGCTAGTG"
, "TCCTAAATTTGAATGGCAAACACAAATAAGATTTAGCAATTCGTGTAGAC"
, "GACCGGGGACTTGCATGATGGGAGCAGCTTTGTTAAACTACGAACGTAAT"
);
STRING bases = "ATCG";
[]INT counts = seq COUNT bases;
# print the sequence with leading character positions #
# find the overall length of the sequence #
INT seq len := 0;
FOR i FROM LWB seq TO UPB seq DO
seq len +:= LEN seq[ i ]
OD;
# compute the minimum field width required for the positions #
INT s len := seq len;
INT width := 1;
WHILE s len >= 10 DO
width +:= 1;
s len OVERAB 10
OD;
# show the sequence #
print( ( "Sequence:", newline, newline ) );
INT start pos := 0;
FOR i FROM LWB seq TO UPB seq DO
print( ( " ", whole( start pos, - width ), " :", seq[ i ], newline ) );
start pos +:= LEN seq[ i ]
OD;
# show the base counts #
print( ( newline, "Bases: ", newline, newline ) );
INT total := 0;
FOR i FROM LWB bases TO UPB bases DO
print( ( " ", bases[ i ], " : ", whole( counts[ i ], - width ), newline ) );
total +:= counts[ i ]
OD;
# show the count of other characters (invalid bases) #
#- if there are any #
IF INT others = UPB counts;
counts[ others ] /= 0
THEN
# there were characters other than the bases #
print( ( newline, "Other: ", whole( counts[ others ], - width ), newline, newline ) );
total +:= counts[ UPB counts ]
FI;
# totals #
print( ( newline, "Total: ", whole( total, - width ), newline ) )
END
END

76
Task/Biorhythms/ALGOL-68/biorhythms.alg Normal file
View file

@ -0,0 +1,76 @@
BEGIN # biorythms #
# code from the Day of the week of Christmas and New Year task #
[]STRING day name =
[]STRING( "SAT", "SUN", "MON", "TUE", "WED", "THU", "FRI" )[ AT 0 ];
PROC day of week = ( INT y, m, d )INT:
BEGIN
INT mm := m;
INT yy := y;
IF mm <= 2 THEN
mm +:= 12;
yy -:= 1
FI;
INT j = yy OVER 100;
INT k = yy MOD 100;
( d + ( ( mm + 1 ) * 26 ) OVER 10 + k + k OVER 4 + j OVER 4 + 5 * j ) MOD 7
END # day of week # ;
# end code from the Day of the week of Christmas and New Year task #
# code from the days between dates task #
PROC gregorian = ( INT y, m, d )INT:
BEGIN
INT n = ( m + 9 ) - ( ( ( m + 9 ) OVER 12 ) * 12 );
INT w = y - ( n OVER 10 );
( 365 * w ) + ( w OVER 4 ) - ( w OVER 100 ) + ( w OVER 400 )
+ ( ( ( n * 306 ) + 5 ) OVER 10 ) + ( d - 1 )
END # gregorian # ;
# end code from the days between dates task #
BEGIN # main routine - translated from the Fortran sample's main program #
PROC double line = VOID: print( ( "=" * 75, newline ) );
PROC in range = ( REAL v, INT low, high )INT:
IF v < low THEN low ELIF v > high THEN high ELSE ENTIER v FI;
REAL pi2 = pi * 2;
INT byear, bmon, bday, tyear, tmon, tday, nday;
print( ( "ENTER YOUR BIRTHDAY YYYY MM DD: " ) );
read( ( byear, bmon, bday ) );
print( ( "ENTER START DATE YYYY MM DD: " ) );
read( ( tyear, tmon, tday ) );
print( ( "ENTER NUMBER OF DAYS TO PLOT : " ) );
read( ( nday ) );
INT jd0 = gregorian( tyear, 1, 1 );
INT jd1 = gregorian( byear, bmon, bday );
INT jd2 := gregorian( tyear, tmon, tday );
INT dob = day of week( byear, bmon, bday );
INT dow := day of week( tyear, tmon, tday );
double line;
print( ( "YOU WERE BORN ON A (", day name[ dob MOD 7 ], ") YOU WERE " ) );
print( ( whole( jd2 - jd1, 0 ), " DAYS OLD ON THE START DATE.", newline ) );
print( ( "-1", 31 * " ", "0", 30 * " ", "+1 DOY", newline ) );
TO nday DO
INT dif = jd2 - jd1;
INT phy = in range( 3.3e1+3.2e1*sin( pi2 * dif / 2.3e1 ), 1, 65 );
INT emd = in range( 3.3e1+3.2e1*sin( pi2 * dif / 2.8e1 ), 1, 65 );
INT men = in range( 3.3e1+3.2e1*sin( pi2 * dif / 3.3e1 ), 1, 65 );
STRING g row := 65 * IF day name[ dow ] = "SUN" THEN "." ELSE " " FI;
g row[ 1 ] := "|";
g row[ 17 ] := ":";
g row[ 33 ] := "|";
g row[ 49 ] := ":";
g row[ 65 ] := "|";
g row[ phy ] := "P";
g row[ emd ] := "E";
g row[ men ] := "M";
IF phy = emd OR phy = men THEN g row[ phy ] := "*" FI;
IF emd = men THEN g row[ emd ] := "*" FI;
print( ( " ", g row, " ", day name[ dow ], " ", whole( jd2 - jd0 + 1, -3 ), newline ) );
jd2 +:= 1;
dow +:= 1 MODAB 7
OD;
double line
END
END

2
Task/Biorhythms/FutureBasic/biorhythms.basic
View file

@ -2,7 +2,7 @@
Biorhythms task for Rosetta Code
https://rosettacode.org/wiki/Biorhythms
Translated from FreeBasic to FutureBasic
Translated from FreeBASIC to FutureBasic
Rich Love May 24, 2024
Oct 16, 2024 fixed the percentage amounts

2
Task/Biorhythms/M2000-Interpreter/biorhythms.m2000
View file

@ -6,7 +6,7 @@ Module Biorhythms {
date bioDay="1972-07-11", transition
for k=1 to 1
long Days=bioDay-birth
Print "Day "+Days+":"
Print "Day "+(bioDay)+":"
string frm="{0:-20} : {1}", pword, dfmt="YYYY-MM-DD"
long position, percentage, length, targetday

63
Task/Biorhythms/Rust/biorhythms.rs Normal file
View file

@ -0,0 +1,63 @@
use chrono::{NaiveDate, ParseError, TimeDelta};
use num_traits::float::FloatConst;
const PHYSICAL_WAVE: i64 = 23;
const EMOTIONAL_WAVE: i64 = 28;
const MENTAL_WAVE: i64 = 33;
const CYCLES: [&str; 3] = ["Physical day ", "Emotional day", "Mental day "];
const LENGTHS: [i64; 3] = [PHYSICAL_WAVE, EMOTIONAL_WAVE, MENTAL_WAVE];
const QUADRANTS: [[&str; 2]; 4] = [
["up and rising", "peak"],
["up but falling", "transition"],
["down and falling", "valley"],
["down but rising", "transition"],
];
/// Parameters assumed to be in YYYY-MM-DD format.
fn biorhythms(birth_date: &str, target_date: &str) -> Result<i64, ParseError> {
let bd = NaiveDate::parse_from_str(birth_date, "%Y-%m-%d")?;
let td = NaiveDate::parse_from_str(target_date, "%Y-%m-%d")?;
let days = (td - bd).num_days();
println!("Born {}, Target {}", birth_date, target_date);
println!("Day {}:", days);
for i in 0..3 {
let length = LENGTHS[i];
let cycle = CYCLES[i];
let position = days % length;
let quadrant: usize = (4 * position as usize) / length as usize;
let mut percent = f64::sin(2. * f64::PI() * position as f64 / length as f64);
percent = percent * 100.0;
let description: String;
if percent > 95. {
description = " peak".to_owned();
} else if percent < -95. {
description = " valley".to_owned();
} else if percent.abs() < 5. {
description = " critical transition".to_owned();
} else {
let days_to_add = (quadrant as i64 + 1) * length / 4 - position;
let transition = td + TimeDelta::days(days_to_add);
let trend = QUADRANTS[quadrant][0];
let next = QUADRANTS[quadrant][1];
description = format!("{:5.1}% ({}, next {} {})", percent, trend, next, transition);
}
println!("{} {:>2} : {}", cycle, position, description);
}
println!();
Ok(0)
}
fn main() {
let date_pairs = [
["1943-03-09", "1972-07-11"],
["1809-01-12", "1863-11-19"],
["1809-02-12", "1863-11-19"], // correct DOB for Abraham Lincoln
];
for date_pair in date_pairs {
match biorhythms(date_pair[0], date_pair[1]) {
Err(_) => println!("Error in biorhythms function parsing {:?}", date_pair),
_ => {}
}
}
}

31
Task/Bitmap-B-zier-curves-Cubic/FutureBasic/bitmap-b-zier-curves-cubic.basic Normal file
View file

@ -0,0 +1,31 @@
void local fn BuildWindow
window 1, @"Cubic Bezier Curve", ( 0, 0, 300, 300 ), NSWindowStyleMaskTitled + NSWindowStyleMaskClosable
WindowSetBackgroundColor( 1, fn ColorBlack )
WindowSubclassContentView(1)
ViewSetNeedsDisplay( _windowContentViewTag )
end fn
void local fn DrawInView( tag as NSInteger )
ColorSetStroke( fn ColorYellow )
BezierPathRef path = fn BezierPathInit
BezierPathMoveToPoint( path, fn CGPointMake( 50, 50 ) )
CGPoint controlPoint1 = fn CGPointMake( 120, 200 )
CGPoint controlPoint2 = fn CGPointMake( 180, 0 )
CGPoint endPoint = fn CGPointMake( 260, 100 )
BezierPathRelativeCurveToPoint( path, controlPoint1, controlPoint2, endPoint )
BezierPathSetLineWidth( path, 4.0 )
BezierPathStroke( path )
end fn
void local fn DoDialog( ev as long, tag as long )
select ( ev )
case _viewDrawRect : fn DrawInView(tag)
case _windowWillClose : end
end select
end fn
fn BuildWindow
on dialog fn DoDialog
HandleEvents

47
Task/Blum-integer/FutureBasic/blum-integer.basic Normal file
View file

@ -0,0 +1,47 @@
begin globals
UInt32 gPrime1
end globals
local fn IsSemiprime( n as UInt32 ) as BOOL
BOOL result = NO
UInt32 d = 3, c = 0
while d * d <= n
while ( n % d = 0 )
if ( c == 2 ) then return NO
n /= d
c += 1
wend
d += 2
wend
gPrime1 = n
result = ( c == 1 )
end fn = result
void local fn BlumIntegers
UInt32 prime2 = 0, n = 3, c = 0
print @"The first 50 Blum integers:"
while ( 1 )
if ( fn IsSemiprime( n ) )
if ( gPrime1 % 4 == 3 )
prime2 = n / gPrime1
if ( prime2 != gPrime1 ) && ( prime2 % 4 == 3 )
c++
if ( c <= 50 )
printf @"%4d\b",n
if ( c % 10 == 0 ) then print
end if
if ( c >= 26828 )
print : print @"The 26828th Blum integer is: "; n
break
end if
end if
end if
end if
n += 2
wend
end fn
fn BlumIntegers
HandleEvents

32
Task/Box-the-compass/FutureBasic/box-the-compass.basic Normal file
View file

@ -0,0 +1,32 @@
window 1,@"Box the Compass"
_Name = 0
_Degrees = 1
// mda defaults to mda _Name
mda(0)=@"North":mda(1)=@"North by east":mda(2)=@"North-northeast"
mda(3)=@"Northeast by north":mda(4)=@"Northeast":mda(5)=@"Northeast by east":mda(6)=@"East-northeast"
mda(7)=@"East by north":mda(8)=@"East":mda(9)=@"East by south":mda(10)=@"East-southeast"
mda(11)=@"Southeast by east":mda(12)=@"Southeast":mda(13)=@"Southeast by south":mda(14)=@"South-southeast"
mda(15)=@"South by east":mda(16)= @"South":mda(17)= @"South by west":mda(18)= @"South-southwest"
mda(19)=@"Southwest by south":mda(20)=@"Southwest":mda(21)=@"Southwest by west":mda(22)=@"West-southwest"
mda(23)=@"West by south":mda(24)=@"West":mda(25)=@"West by north":mda(26)=@"West-northwest"
mda(27)=@"Northwest by west":mda(28)=@"Northwest":mda(29)=@"Northwest by north":mda(30)=@"North-northwest"
mda(31)=@"North by west":mda(32)=@"North"
mda _Degrees (0) = { 0, 16.87, 16.88, 33.75, 50.62, 50.63,¬
67.5, 84.37, 84.38, 101.25, 118.12, 118.13, 135, 151.87, 151.88, 168.75,¬
185.62, 185.63, 202.5, 219.37, 219.38, 236.25, 253.12, 253.13, 270,¬
286.87, 286.88, 303.75, 320.62, 320.63, 337.5, 354.37, 354.38 }
unsigned Long i, j
For i = 0 To 32
j = fix((mda_double _Degrees(i) + 5.625) / 11.25)
If j > 31 Then j = j - 32
Print Using "###.## "; (mda_double _Degrees(i));
Print Using "## "; j;
Print mda _Name(j)
Next
handleevents

134
Task/Brace-expansion/FreeBASIC/brace-expansion.basic Normal file
View file

@ -0,0 +1,134 @@
Type StringArray
elements(Any) As String
length As Integer
End Type
Type ItemResult
items As StringArray
remaining As String
End Type
Type GroupResult
items As StringArray
remaining As String
success As Boolean
End Type
Declare Function GetGroup(s As String, depth As Integer) As GroupResult
Declare Function GetItem(s As String, depth As Integer = 0) As ItemResult
Function ConcatArrays(arr1 As StringArray, arr2 As StringArray) As StringArray
Dim result As StringArray
Dim totalLen As Integer = arr1.length * arr2.length
Redim result.elements(totalLen - 1)
result.length = totalLen
Dim idx As Integer = 0
For i As Integer = 0 To arr1.length - 1
For j As Integer = 0 To arr2.length - 1
result.elements(idx) = arr1.elements(i) & arr2.elements(j)
idx += 1
Next j
Next i
Return result
End Function
Function GetItem(s As String, depth As Integer = 0) As ItemResult
Dim result As ItemResult
Redim result.items.elements(0)
result.items.elements(0) = ""
result.items.length = 1
While Len(s) > 0
Dim c As String = Left(s, 1)
If depth > 0 Andalso (c = "," Orelse c = "}") Then
result.remaining = s
Return result
Elseif c = "{" Then
Dim groupResult As GroupResult = GetGroup(Mid(s, 2), depth + 1)
If groupResult.success Then
result.items = ConcatArrays(result.items, groupResult.items)
s = groupResult.remaining
Continue While
End If
Elseif c = "\" Andalso Len(s) > 1 Then
s = Mid(s, 2)
c = "\" & Left(s, 1)
End If
For i As Integer = 0 To result.items.length - 1
result.items.elements(i) &= c
Next
s = Mid(s, 2)
Wend
result.remaining = s
Return result
End Function
Function GetGroup(s As String, depth As Integer) As GroupResult
Dim result As GroupResult
Dim comma As Boolean = False
result.success = False
Redim result.items.elements(0)
result.items.length = 0
While Len(s) > 0
Dim itemResult As ItemResult = GetItem(s, depth)
If Len(itemResult.remaining) = 0 Then Exit While
s = itemResult.remaining
If result.items.length = 0 Then
result.items = itemResult.items
Else
Dim newLen As Integer = result.items.length + itemResult.items.length
Redim Preserve result.items.elements(newLen - 1)
For i As Integer = 0 To itemResult.items.length - 1
result.items.elements(result.items.length + i) = itemResult.items.elements(i)
Next
result.items.length = newLen
End If
If Left(s, 1) = "}" Then
result.success = True
If comma Then
result.remaining = Mid(s, 2)
Return result
End If
For i As Integer = 0 To result.items.length - 1
result.items.elements(i) = "{" & result.items.elements(i) & "}"
Next
result.remaining = Mid(s, 2)
Return result
End If
If Left(s, 1) = "," Then
comma = True
s = Mid(s, 2)
End If
Wend
Return result
End Function
' Main program
Dim testStrings(3) As String
testStrings(0) = "~/{Downloads,Pictures}/*.{jpg,gif,png}"
testStrings(1) = "It{{em,alic}iz,erat}e{d,}, please."
testStrings(2) = "{,{,gotta have{ ,\, again\, }}more }cowbell!"
testStrings(3) = "{}} some }{,{\\{ edge, edge} \,}{ cases, {here} \\\\\}"
For i As Integer = 0 To 3
Print testStrings(i) & Chr(10) & String(44, "-")
Dim result As ItemResult = GetItem(testStrings(i))
For j As Integer = 0 To result.items.length - 1
Print result.items.elements(j)
Next
Print
Next
Sleep

4
Task/CSV-data-manipulation/00-TASK.txt
View file

@ -21,5 +21,7 @@ For this task we will use the following CSV file:
<li/> Show how to add a column, headed 'SUM', of the sums of the rows.
<li/> If possible, illustrate the use of built-in or standard functions, methods, or libraries, that handle generic CSV files.
</ul>
<br>
;Related tasks:
* [[Convert_CSV_records_to_TSV]]
<br><br>

42
Task/Caesar-cipher/FutureBasic/caesar-cipher.basic Normal file
View file

@ -0,0 +1,42 @@
CFStringRef local fn Encrypt( s as CFStringRef, key as int )
CFMutableStringRef s1 = fn MutableStringWithString(s)
for int i = 0 to len(s1) - 1
unichar c = ucc(s1,i)
select
case ( c >= _"A" && c <= _"Z")
c += key : if ( c > _"Z" ) then c -= 26
case ( c >= _"a" && c <= _"z" )
c += key : if ( c > _"z" ) then c -= 26
end select
mid(s1,i,1) = ucs(c)
next
end fn = s1
CFStringRef local fn Decrypt( s as CFStringRef, key as int )
CFMutableStringRef s1 = fn MutableStringWithString(s)
for int i = 0 to len(s1) - 1
unichar c = ucc(s1,i)
select
case ( c >= _"A" && c <= _"Z")
c -= key : if ( c < _"A" ) then c += 26
case ( c >= _"a" && c <= _"z" )
c -= key : if ( c < _"a" ) then c += 26
end select
mid(s1,i,1) = ucs(c)
next
end fn = s1
void local fn DoIt
CFStringRef s = @"The sun's not yellow, it's chicken"
print s
s = fn Encrypt( s, 6 )
print s
s = fn Decrypt( s, 6 )
print s
end fn
fn DoIt
HandleEvents

0
Task/Calculating-the-value-of-e/Rust/calculating-the-value-of-e.rs → Task/Calculating-the-value-of-e/Rust/calculating-the-value-of-e-1.rs
View file

36
Task/Calculating-the-value-of-e/Rust/calculating-the-value-of-e-2.rs Normal file
View file

@ -0,0 +1,36 @@
fn spigot(a: &mut Vec<u32>) -> u32 {
a.iter_mut().enumerate().rfold(0,|q, (idx, ai)|{
let ai1 = *ai * 10 + q;
let idx1 = 2 + idx as u32;
*ai = ai1 % idx1;
ai1 / idx1
})
}
fn spigot_loop(num: u32) {
let line_len = 80;
let mut arr = vec!(1u32; 1 + num as usize);
print!("2.");
for count in 3..num + 3 {
print!("{}", spigot(&mut arr));
if count % line_len == 0 || count == num + 2 {println!()};
}
}
fn default() -> u32 {
println!("invalid param - use default");
500
}
fn main() {
let args: Vec<String> = std::env::args().collect();
let num_digits = match args.as_slice() {
[_, arg1] => match arg1.parse::<u32>() {
Ok(i) => i,
Err(_) => default()
},
_ => default()
};
spigot_loop(num_digits);
}

14
Task/Calkin-Wilf-sequence/ALGOL-68/calkin-wilf-sequence.alg
View file

@ -32,14 +32,7 @@ BEGIN
num OF result//den OF result
);
OP - = (FRAC a, b)FRAC: a + -b,
* = (FRAC a, b)FRAC: (
INT num = num OF a * num OF b,
den = den OF a * den OF b;
INT common = gcd(num, den);
(num OVER common) // (den OVER common)
);
OP - = (FRAC a, b)FRAC: a + -b;
OP - = (FRAC frac)FRAC: (-num OF frac, den OF frac);
# ============================================================== #
@ -65,7 +58,6 @@ BEGIN
# end code from the Continued fraction/Arithmetic/Construct from rational number task #
# Additional FRACrelated operators #
OP * = ( INT a, FRAC b )FRAC: ( num OF b * a ) // den OF b;
OP / = ( FRAC a, b )FRAC: ( num OF a * den OF b ) // ( num OF b * den OF a );
OP FLOOR = ( FRAC a )INT: num OF a OVER den OF a;
OP + = ( INT a, FRAC b )FRAC: ( a // 1 ) + b;
@ -105,7 +97,7 @@ BEGIN
# continued fraction, starting at the least significant #
INT digit := 1;
FOR d pos FROM cf length BY -1 TO 1 DO
FOR i TO cf[ d pos ] DO
TO cf[ d pos ] DO
result *:= 2 +:= digit
OD;
digit := IF digit = 0 THEN 1 ELSE 0 FI
@ -124,7 +116,7 @@ BEGIN
print( ( newline ) );
# show the position of a specific element in the sequence #
print( ( "Position of 83116/51639 in the sequence: "
, whole( position in calkin wilf sequence( 83116//51639 ), 0 )
, whole( position in calkin wilf sequence( 83116//51639 ), 0 ), newline
)
)
END

4
Task/Camel-case-and-snake-case/ALGOL-68/camel-case-and-snake-case.alg
View file

@ -59,7 +59,7 @@ BEGIN # convert camel case to and from snake case #
result +:= c
ELIF NOT ISBREAK c THEN
# not a break - convert to lower case if necessary and move to the next #
result +:= TOLOWER c;
result +:= TOLOWER c
ELSE
# have a separator - skip all subsequent separators and upcase the follower #
BOOL have break := TRUE;
@ -83,7 +83,7 @@ BEGIN # convert camel case to and from snake case #
THEN s
ELSE
STRING result := s;
FOR i FROM s len + 1 TO len DO " " +=: result OD;
FROM s len + 1 TO len DO " " +=: result OD;
result
FI # PAD # ;
# returns s with leading and trailing spaces removed #

6
Task/Carmichael-3-strong-pseudoprimes/REXX/carmichael-3-strong-pseudoprimes-2.rexx
View file

@ -24,7 +24,7 @@ parse arg x
n = 0
do p1 = 3 by 2 to x
/* Method Janeson */
if \ IsPrime(p1) then
if \ Prime(p1) then
iterate p1
pm = p1-1; ps = -p1*p1
do h3 = 1 to pm
@ -37,10 +37,10 @@ do p1 = 3 by 2 to x
if t2 <> d//h3 then
iterate d
p2 = 1+t1%d
if \ IsPrime(p2) then
if \ Prime(p2) then
iterate d
p3 = 1+(p1*p2%h3)
if \ IsPrime(p3) then
if \ Prime(p3) then
iterate d
if (p2*p3)//pm <> 1 then
iterate d

125
Task/Catalan-numbers/Isabelle/catalan-numbers-1.isabelle Normal file
View file

@ -0,0 +1,125 @@
theory Catalan_Numbers
imports
"HOL-Computational_Algebra.Computational_Algebra" "HOL-Library.Code_Target_Numeral"
begin
(* recursive definition *)
fun catalan :: "nat ⇒ nat" where
"catalan 0 = 1"
| [simp del]: "catalan (Suc n) = (∑i≤n. catalan i * catalan (n - i))"
(* the generating function F(X) = ∑n. C(n)X^n of the Catalan numbers
as a formal power series *)
definition fps_catalan :: "real fps" where "fps_catalan = Abs_fps (real ∘ catalan)"
(* C(X) satisfies the identity C(X) = 1 + X C(X)^2 *)
lemma fps_catalan_recurrence:
"fps_catalan = 1 + fps_X * fps_catalan^2"
proof (rule fps_ext)
fix n :: nat
show "fps_nth fps_catalan n = fps_nth (1 + fps_X * fps_catalan^2) n"
by (cases n) (simp_all add: fps_square_nth catalan.simps(2) fps_catalan_def)
qed
(* Solving for C we get C(X) = (1 - sqrt(1 - 4x)) / (2x) *)
lemma fps_catalan_fps_binomial:
"fps_catalan = (1/2 * (1 - (fps_binomial (1/2) oo (-4*fps_X)))) / fps_X"
proof -
let ?F = "fps_catalan"
have "fps_X * (1 + fps_X * ?F^2) = fps_X * ?F"
by (simp only: fps_catalan_recurrence [symmetric])
hence "(1 / 2 - fps_X * ?F)⇧2 = - fps_X + 1 / 4"
by (simp add: algebra_simps power2_eq_square fps_numeral_simps)
also have "… = (1/2 * (fps_binomial (1/2) oo (-4*fps_X)))^2"
by (simp add: power_mult_distrib div_power fps_binomial_1 fps_binomial_power
fps_compose_power fps_compose_add_distrib ring_distribs)
finally have "1/2 - fps_X * ?F = 1/2 * (fps_binomial (1/2) oo (-4*fps_X))"
by (rule fps_power_eqD) simp_all
hence "fps_X*?F = 1/2 * (1 - (fps_binomial (1/2) oo (-4*fps_X)))" by algebra
thus ?thesis
by (metis fps_X_neq_zero nonzero_mult_div_cancel_left)
qed
(* A closed form for the Catalan numbers in terms of the generalised binomial coefficients
can be read off directly from this solution for C(x), namely:
c_n = 2 (-4)^n B(1/2, n+1) *)
lemma catalan_closed_form_gbinomial:
"real (catalan n) = 2 * (-4) ^ n * ((1/2) gchoose (n+1))"
proof -
have "(catalan n :: real) = fps_nth fps_catalan n"
by (simp add: fps_catalan_def)
also have "… = 2 * (-4) ^ n * ((1/2) gchoose (n+1))"
by (subst fps_catalan_fps_binomial)
(simp add: fps_div_fps_X_nth numeral_fps_const fps_compose_linear)
finally show ?thesis .
qed
(* Simplifying the generalised binomial coefficients to regular ones we get
another closed form: c_n = B(2n, n) / (n+1) *)
lemma catalan_closed_form':
"catalan n * (n + 1) = (2*n) choose n"
proof -
have "real ((2*n) choose n) = fact (2*n) / (fact n)^2"
by (simp add: binomial_fact power2_eq_square)
also have "(fact (2*n) :: real) = 4^n * pochhammer (1 / 2) n * fact n"
by (simp add: fact_double power_mult)
also have "… / (fact n)^2 / real (n+1) = real (catalan n)"
by (simp add: catalan_closed_form_gbinomial gbinomial_pochhammer pochhammer_rec
field_simps power2_eq_square power_mult_distrib [symmetric] del: of_nat_Suc)
finally have "real (catalan n * (n+1)) = real ((2*n) choose n)" by (simp add: field_simps)
thus ?thesis
by linarith
qed
theorem catalan_closed_form: "catalan n = ((2*n) choose n) div (n + 1)"
by (subst catalan_closed_form' [symmetric], subst div_mult_self_is_m) auto
(* With this, it is now also easy to derive a linear recurrence of order 1
(with polynomial coefficients): *)
lemma catalan_rec':
"(n + 2) * catalan (n + 1) = 2 * (2 * n + 1) * catalan n"
proof (cases "n > 0")
case True
have "real (catalan (n + 1) * (n + 1 + 1)) =
real (catalan n * (n + 1)) * 2 * real (2 * n + 1) / real (n + 1)"
using True unfolding catalan_closed_form'
by (simp add: fact_reduce binomial_fact divide_simps) (auto simp: algebra_simps)?
also have "… = real (2 * (2 * n + 1) * catalan n)"
by (simp del: of_nat_Suc add: divide_simps) (auto simp: algebra_simps)?
also have "catalan (n + 1) * (n + 1 + 1) = (n + 2) * catalan (n + 1)"
by simp
finally show ?thesis
by linarith
qed (auto simp: catalan.simps(2))
theorem catalan_rec:
"catalan (Suc n) = (catalan n * (2*(2*n+1))) div (n+2)"
by (subst mult.commute, subst catalan_rec' [symmetric], subst div_mult_self1_is_m) auto
(* To make the computation more efficient, we now derive a simple
tail-recursive version of this *)
function catalan_aux where [simp del]:
"catalan_aux n k acc =
(if k ≥ n then acc else catalan_aux n (Suc k) ((acc * (2*(2*k+1))) div (k+2)))"
by auto
termination by (relation "Wellfounded.measure (λ(a,b,_). a - b)") simp_all
lemma catalan_aux_correct:
assumes "k ≤ n"
shows "catalan_aux n k (catalan k) = catalan n"
using assms
proof (induction n k "catalan k" rule: catalan_aux.induct)
case (1 n k)
show ?case
proof (cases "k < n")
case True
hence "catalan_aux n k (catalan k) = catalan_aux n (Suc k) (catalan (Suc k))"
by (subst catalan_rec; subst catalan_aux.simps) auto
with 1 True show ?thesis by (simp add: catalan_rec)
qed (insert "1.prems", simp_all add: catalan_aux.simps)
qed
lemma catalan_code [code]: "catalan n = catalan_aux n 0 1"
using catalan_aux_correct[of 0 n] by simp
end

6
Task/Catalan-numbers/Isabelle/catalan-numbers-2.isabelle Normal file
View file

@ -0,0 +1,6 @@
theory Catalan_Numbers
value "map catalan [0..<15]"
(* Output:
"[1, 1, 2, 5, 14, 42, 132, 429, 1430, 4862, 16796, 58786, 208012, 742900, 2674440]"
:: "nat list"
*)

25
Task/Catamorphism/FutureBasic/catamorphism.basic Normal file
View file

@ -0,0 +1,25 @@
void local fn DoIt
CFArrayRef nums = @[@1, @2, @3, @4, @5, @6, @7, @8, @9, @10]
print @"nums:",,concat @", ",(nums)
print
print @"sum: ",,intval(fn ObjectValueForKeyPath( nums, @"@sum.self" ))
long product = 1
for CFNumberRef num in nums
product *= intval(num)
next
print @"product:",product
print @"concat:",,concat(@"",nums)
print @"min: ",,intval(fn ObjectValueForKeyPath( nums, @"@min.self" ))
print @"max: ",,intval(fn ObjectValueForKeyPath( nums, @"@max.self" ))
print @"avg: ",,intval(fn ObjectValueForKeyPath( nums, @"@avg.self" ))
end fn
fn DoIt
HandleEvents

122
Task/Chat-server/FreeBASIC/chat-server.basic Normal file
View file

@ -0,0 +1,122 @@
#include once "windows.bi"
#include once "win/winsock2.bi"
Type SOCKET As Ulongint
Type ThreadCallback As Sub(Byval As Any Ptr)
Const MAX_CLIENTS = 10
Const CRLF = Chr(13) & Chr(10)
Const BUFFER_SIZE = 256
Dim Shared clients(MAX_CLIENTS) As SOCKET
Dim Shared nicknames(MAX_CLIENTS) As String
Dim Shared clientCount As Integer = 0
' Initialize Winsock
Dim As WSADATA wsaData
If WSAStartup(&h0202, @wsaData) Then
Print "Error initializing Winsock"
End 1
End If
' Create server socket
Dim As SOCKET serverSocket = WSASocket(AF_INET, SOCK_STREAM, IPPROTO_TCP, NULL, 0, 0)
If serverSocket = INVALID_SOCKET Then
Print "Error creating socket"
WSACleanup()
End 1
End If
' Configure server address
Dim As sockaddr_in serverAddr
With serverAddr
.sin_family = AF_INET
.sin_addr.s_addr = INADDR_ANY
.sin_port = htons(8080)
End With
' Bind socket
If bind(serverSocket, Cast(sockaddr Ptr, @serverAddr), Sizeof(sockaddr_in)) = SOCKET_ERROR Then
Print "Error binding socket"
closesocket(serverSocket)
WSACleanup()
End 1
End If
' Listen for incoming connections
If listen(serverSocket, SOMAXCONN) = SOCKET_ERROR Then
Print "Error listening on socket"
closesocket(serverSocket)
WSACleanup()
End 1
End If
Print "Chat server is running on port 8080"
Sub broadcastMessage(message As String)
Dim As String fullMsg = message
For i As Integer = 0 To clientCount - 1
If clients(i) <> 0 Then
send(clients(i), Strptr(fullMsg), Len(fullMsg), 0)
End If
Next i
End Sub
Sub handleClient(Byval param As Any Ptr)
Dim As Integer clientIndex = Cast(Integer, param)
Dim As SOCKET clientSocket = clients(clientIndex)
Dim As String nickname
Dim As ZString * BUFFER_SIZE buffer
Dim As Long bytesReceived
' Get nickname
Dim As String welcomeMsg = "Enter your nickname: "
send(clientSocket, Strptr(welcomeMsg), Len(welcomeMsg), 0)
bytesReceived = recv(clientSocket, @buffer, BUFFER_SIZE-1, 0)
If bytesReceived > 0 Then
nickname = Left(buffer, bytesReceived - 2)
nicknames(clientIndex) = nickname
' Announce new user
broadcastMessage(nickname & " has joined the chat." & CRLF)
' Message loop
Do
bytesReceived = recv(clientSocket, @buffer, BUFFER_SIZE-1, 0)
If bytesReceived <= 0 Then Exit Do
buffer[bytesReceived] = 0
broadcastMessage(nickname & ": " & *Cast(ZString Ptr, @buffer) & CRLF)
Loop
' Announce departure
broadcastMessage(nickname & " has left the chat." & CRLF)
End If
' Cleanup
closesocket(clientSocket)
clients(clientIndex) = 0
nicknames(clientIndex) = ""
End Sub
' Main server loop
Do
Dim As sockaddr_in clientAddr
Dim As Long clientAddrLen = Sizeof(sockaddr_in)
Dim As SOCKET clientSocket = accept(serverSocket, Cast(sockaddr Ptr, @clientAddr), @clientAddrLen)
If clientSocket <> INVALID_SOCKET Then
If clientCount < MAX_CLIENTS Then
clients(clientCount) = clientSocket
clientCount += 1
Threadcreate(Cast(ThreadCallback, @handleClient), Cast(Any Ptr, clientCount - 1))
Else
Dim As String fullMsg = "Server is full." & CRLF
send(clientSocket, Strptr(fullMsg), Len(fullMsg), 0)
closesocket(clientSocket)
End If
End If
Loop
' Final cleaning
closesocket(serverSocket)
WSACleanup()

21
Task/Chinese-zodiac/FutureBasic/chinese-zodiac.basic Normal file
View file

@ -0,0 +1,21 @@
void local fn DoIt
CFArrayRef yy = @[@"yang",@"yin"]
CFArrayRef elements = @[@"Wood",@"Fire",@"Earth",@"Metal",@"Water"]
CFArrayRef animals = @[@"Rat",@"Ox",@"Tiger",@"Rabbit",@"Dragon",
@"Snake",@"Horse",@"Goat",@"Monkey",@"Rooster",@"Dog",@"Pig"]
long yr, y, e, a, i, tests(5) = {1801,1861,1984,2020,2186,76543}
CFStringRef outstr
for i = 0 to 5
yr = tests(i)
y = yr % 2
e = (yr-4) % 5
a = (yr-4) %12
outstr = concat(@"",@(yr),@" is the year of the ",elements[e],@" ",animals[a],@" (",yy[y],@")")
print outstr
next
end fn
fn DoIt
HandleEvents

17
Task/Chinese-zodiac/M2000-Interpreter/chinese-zodiac.m2000 Normal file
View file

@ -0,0 +1,17 @@
module Chinese_zodiac {
yy= ("yang", "yin")
elements = ("Wood", "Fire", "Earth", "Metal", "Water")
animals = ("Rat", "Ox", "Tiger", "Rabbit", "Dragon", "Snake", "Horse", "Goat", "Monkey", "Rooster", "Dog", "Pig")
testThis = (1801, 1861, 1984, 2020, 2186, 76543)
i=each(testThis)
while i
yr = array(i)
y = yr mod 2
e = (yr - 4) mod 5
a = (yr - 4) mod 12
outstr = yr+" is the year of the "
outstr += elements#val$(e)+" " + animals#val$(a) + " (" + yy#val$(y) + ")."
print outstr
end while
}
Chinese_zodiac

4
Task/Circular-primes/ALGOL-68/circular-primes.alg
View file

@ -52,12 +52,12 @@ BEGIN # find circular primes - primes where all cyclic permutations #
END # CIRCULARPRIMESIEVE # ;
# construct a sieve of circular primes up to 999 999 #
# only the first permutation is included #
[]BOOL prime = CIRCULARPRIMESIEVE 999 999;
[]BOOL c prime = CIRCULARPRIMESIEVE 999 999;
# print the first 19 circular primes #
INT c count := 0;
print( ( "First 19 circular primes: " ) );
FOR i WHILE c count < 19 DO
IF prime[ i ] THEN
IF c prime[ i ] THEN
print( ( " ", whole( i, 0 ) ) );
c count +:= 1
FI

9
Task/Circular-primes/REXX/circular-primes-2.rexx
View file

@ -21,7 +21,7 @@ do i = 1 to p
b = Right(b,l-1)||Left(b,1)
if b < a then
iterate i
if \ IsPrime(b) then
if \ prime(b) then
iterate i
end
call Charout ,a' '
@ -38,7 +38,7 @@ numeric digits 320
say 'Next 3 circular primes:'
do i = 7 to 320
r = Repunit(i)
if IsPrime(r) then
if prime(r) then
call charout ,'R('i') '
end
say
@ -51,7 +51,7 @@ procedure expose glob.
call Time('r')
numeric digits 1040
say 'Primality of R(1031):'
if IsPrime(Repunit(1031)) then
if prime(Repunit(1031)) then
say 'R(1031) is probable prime'
else
say 'R(1031) is composite'
@ -66,6 +66,7 @@ arg x
/* Formula */
return Copies('1',x)
include Numbers
include Functions
include Numbers
include Sequences
include Abend

29
Task/Cistercian-numerals/ALGOL-68/cistercian-numerals.alg
View file

@ -57,18 +57,19 @@ BEGIN # draw some Cistercian Numerals #
lines[ i ][ pos : ( pos + cw ) - 1 ] := STRING( cn[ i, : ] )
OD # print cistercian # ;
[]INT tests = ( 0, 20, 300, 4000, 5555, 6789, 1968 );
# construct an array of blank lines and insert the Cistercian Numereals #
[ 1 : ch ]STRING lines; # into them #
FOR i FROM LWB lines TO UPB lines DO
lines[ i ] := " " * ( ( ( UPB tests -LWB tests ) + 1 ) * ( cw * 2 ) )
OD;
FOR i FROM LWB tests TO UPB tests DO print( ( whole( tests[ i ], - cw ), " " * cw ) ) OD;
print( ( newline ) );
INT i pos := 1 - ( cw * 2 );
FOR i FROM LWB tests TO UPB tests DO
insert cistercian( TOCISTERCIAN tests[ i ], lines, i pos +:= cw * 2 )
OD;
FOR i FROM LWB lines TO UPB lines DO print( ( lines[ i ], newline ) ) OD
BEGIN
[]INT tests = ( 0, 20, 300, 4000, 5555, 6789, 1968 );
# construct an array of blank lines and insert the #
[ 1 : ch ]STRING lines; # Cistercian Numereals into them #
FOR i FROM LWB lines TO UPB lines DO
lines[ i ] := " " * ( ( ( UPB tests -LWB tests ) + 1 ) * ( cw * 2 ) )
OD;
FOR i FROM LWB tests TO UPB tests DO print( ( whole( tests[ i ], - cw ), " " * cw ) ) OD;
print( ( newline ) );
INT i pos := 1 - ( cw * 2 );
FOR i FROM LWB tests TO UPB tests DO
insert cistercian( TOCISTERCIAN tests[ i ], lines, i pos +:= cw * 2 )
OD;
FOR i FROM LWB lines TO UPB lines DO print( ( lines[ i ], newline ) ) OD
END
END

2
Task/Colorful-numbers/ALGOL-68/colorful-numbers.alg
View file

@ -31,7 +31,7 @@ BEGIN # find colourful numbers: numbers where the product of every sub-group #
FOR group start TO ( s end + 1 ) - group width WHILE unique DO
INT product := 1;
INT g pos := group start - 1;
FOR i TO group width DO product *:= dg[ g pos +:= 1 ] OD;
TO group width DO product *:= dg[ g pos +:= 1 ] OD;
dg[ dg pos +:= 1 ] := product;
FOR i TO dg pos - 1 WHILE unique DO
unique := dg[ i ] /= dg[ dg pos ]

16
Task/Colour-pinstripe-Display/GW-BASIC/colour-pinstripe-display.basic Normal file
View file

@ -0,0 +1,16 @@
10 SCREEN 8
20 CLS
30 W = 640: H = 200
40 H = H \ 4
50 Y2 = H - 1
60 FOR I = 1 TO 4
70 COL = 0
80 Y = (I - 1) * H
90 FOR X = 1 TO W STEP I
100 IF COL MOD 15 = 0 THEN COL = 0
110 LINE (X, Y)-(X + I, Y + H), COL, BF
120 COL = COL + 1
130 NEXT X
140 NEXT I
150 WHILE INKEY$= "": WEND
160 END

15
Task/Colour-pinstripe-Display/MSX-Basic/colour-pinstripe-display.basic Normal file
View file

@ -0,0 +1,15 @@
10 SCREEN 3 ' SCREEN 7 en MSX-2
20 CLS
30 W = 256: H = 192 ' W = 512: H = 212
40 H = H \ 4
50 Y2 = H - 1
60 FOR I = 1 TO 4
70 COL = 0
80 Y = (I - 1) * H
90 FOR X = 1 TO W STEP I
100 IF COL MOD 15 = 0 THEN COL = 0
110 LINE (X, Y)-(X + I, Y + H), COL, BF
120 COL = COL + 1
130 NEXT X
140 NEXT I
150 GOTO 150

2
Task/Colour-pinstripe-Display/QBasic/colour-pinstripe-display.basic
View file

@ -1,7 +1,7 @@
SCREEN 12
w = 640: h = 480
h = h / 4
h = h \ 4
y2 = h - 1
FOR i = 1 TO 4

8
Task/Compare-length-of-two-strings/ALGOL-68/compare-length-of-two-strings.alg
View file

@ -2,11 +2,11 @@ BEGIN # compare string lengths #
# returns the length of s using the builtin UPB and LWB operators #
OP LENGTH = ( STRING s )INT: ( UPB s + 1 ) - LWB s;
# prints s and its length #
PROC print string = ( STRING s )VOID:
PROC show string = ( STRING s )VOID:
print( ( """", s, """ has length: ", whole( LENGTH s, 0 ), " bytes.", newline ) );
STRING shorter = "short";
STRING not shorter = "longer";
IF LENGTH shorter > LENGTH not shorter THEN print string( shorter ) FI;
print string( not shorter );
IF LENGTH shorter <= LENGTH not shorter THEN print string( shorter ) FI
IF LENGTH shorter > LENGTH not shorter THEN show string( shorter ) FI;
show string( not shorter );
IF LENGTH shorter <= LENGTH not shorter THEN show string( shorter ) FI
END

3
Task/Compile-time-calculation/FutureBasic/compile-time-calculation.basic Normal file
View file

@ -0,0 +1,3 @@
_testConst = 5 + 3 + 10
print _testConst
HandleEvents

68
Task/Composite-numbers-k-with-no-single-digit-factors-whose-factors-are-all-substrings-of-k/FutureBasic/composite-numbers-k-with-no-single-digit-factors-whose-factors-are-all-substrings-of-k.basic Normal file
View file

@ -0,0 +1,68 @@
include "NSLog.incl"
_max = 30000000
uint32 primes(_max / 16)
uint8 list( _max / 16)
local fn sieve //List primes via Sieve of Eratosthenes
int np, num, count = 0
list(0) = 1
//fn memset( @list(0), 0, _max / 16 )
for num = 3 to _max step 2
if list(num >> 4) & bit((num & 15) >> 1) then continue
primes(count) = num
count++
np = num * num
while np < _max
list(np >> 4) |= bit((np & 15) >> 1)
np += num << 1
wend
next
end fn
local fn AisInB(a as int, b as int) as bool
uint32 mag = 100
while mag < a
mag *= 10
wend
while a <= b
if a == (b % mag) then exit fn = yes
b /= 10
wend
end fn = no
clear local fn factorsInSequence
uint32 f = 3, num, n, count = 0
for n = 11^2 to _max step 2
if (n mod 3 && n mod 5 && n mod 7) == 0 then continue //next n
f = 3 : num = n
while primes(f)^2 < n
if num % primes(f) then f++ : continue //not a factor--next f
if fn AisInB( primes(f), n) == no then break // factor not in n--next n
num /= primes(f)
if (list(num >> 4) & bit((num & 15) >> 1)) == 0
if fn AisInB(num, n) then num = 1
end if
if num == 1
count ++//:breakpoint n, primes(f)
nslog( @"%4d: %d", count,n )
if count < 20 then break else exit fn //next n unless done
end if
wend
next
end fn
nsLogSetTitle(@"Integers whose factors are substrings")
CFTimeInterval t : t = fn CACurrentMediaTime
fn sieve
nslog( @"\n Sieve and list of primes built in %.3f sec.\n",(fn CACurrentMediaTime - t))
fn factorsInSequence
nslog( @"\n Total runtime = %.3f sec.",(fn CACurrentMediaTime - t))
handleevents

48
Task/Consecutive-primes-with-ascending-or-descending-differences/REXX/consecutive-primes-with-ascending-or-descending-differences-2.rexx
View file

@ -1,42 +1,37 @@
call Time('r')
parse version version; say version
glob. = ''; numeric digits 10
glob. = ''; numeric digits 10; t = 1e7
say 'Consecutive primes - Using REXX libraries'
say
call CollectPrimes
call CalculateDeltas
call Sequence 'A'
call Show 'A'
call Sequence 'D'
call Show 'D'
call Primes t
call Deltas
call Sequence 'A',t
call Sequence 'D',t
say Format(Time('e'),,3) 'seconds'
exit
CollectPrimes:
/* Collect all primes */
n = 1e6; p = Primes(n)
return
CalculateDeltas:
Deltas:
/* Calculate deltas between pairs of primes */
procedure expose prim. delta.
delta. = 0
do i = 2 to p
do i = 2 to prim.0
h = i-1; delta.i = prim.prime.i-prim.prime.h
end
p = p+1
return
Sequence:
/* Find longest strict sequence */
arg seq
if seq = 'A' then
/* Find and show longest strict sequence */
procedure expose delta. glob. prim.
arg ad,t
p = prim.0+1
if ad = 'A' then
delta.p = 0
else
delta.p = n
d = 0; f = 1; l = 1; len = 0
do i = 2 to p
if (seq = 'A' & delta.i > d),
| (seq = 'D' & delta.i < d) then do
if (ad = 'A' & delta.i > d),
| (ad = 'D' & delta.i < d) then do
d = delta.i; l = i
end
else do
@ -47,17 +42,12 @@ do i = 2 to p
f = i-1; l = i; d = delta.i
end
end
return
Show:
/* Show results */
arg seq
if seq = 'A' then
if ad = 'A' then
a = 'ascending'
else
a = 'descending'
say 'For primes <' n', the longest' a 'sequence was' len 'consecutive primes.'
say 'The first one (with differences) is:'
say 'For primes <' t', the longest' a 'sequence was' len 'consecutive primes.'
say 'These are (with differences):'
do i = first to last-1
j = i+1
call charout ,prim.prime.i '('delta.j') '
@ -66,5 +56,5 @@ call charout ,prim.prime.last
say; say
return
include Numbers
include Sequences
include Functions

24
Task/Continued-fraction-Arithmetic-Construct-from-rational-number/ALGOL-68/continued-fraction-arithmetic-construct-from-rational-number.alg
View file

@ -10,9 +10,6 @@ BEGIN # construct continued fraction representations of rational numbers #
PROC gcd = (INT a, b) INT: # greatest common divisor #
(a = 0 | b |: b = 0 | a |: ABS a > ABS b | gcd(b, a MOD b) | gcd(a, b MOD a));
PROC lcm = (INT a, b)INT: # least common multiple #
a OVER gcd(a, b) * b;
PRIO // = 9; # higher then the ** operator #
OP // = (INT num, den)FRAC: ( # initialise and normalise #
INT common = gcd(num, den);
@ -23,28 +20,12 @@ BEGIN # construct continued fraction representations of rational numbers #
FI
);
OP + = (FRAC a, b)FRAC: (
INT common = lcm(den OF a, den OF b);
FRAC result := ( common OVER den OF a * num OF a + common OVER den OF b * num OF b, common );
num OF result//den OF result
);
OP - = (FRAC a, b)FRAC: a + -b,
* = (FRAC a, b)FRAC: (
INT num = num OF a * num OF b,
den = den OF a * den OF b;
INT common = gcd(num, den);
(num OVER common) // (den OVER common)
);
OP - = (FRAC frac)FRAC: (-num OF frac, den OF frac);
# ============================================================== #
# end code from the Arithmetic/Rational task #
[]FRAC examples = ( 1//2, 3//1, 23//8, 13//11, 22//7, -151//77 );
[]FRAC sqrt2 = ( 14142//10000, 141421//100000, 1414214//1000000, 14142136//10000000 );
[]FRAC pi = ( 31//10, 314//100, 3142//1000, 31428//10000
[]FRAC pif = ( 31//10, 314//100, 3142//1000, 31428//10000
, 314285//100000, 3142857//1000000, 31428571//10000000, 314285714//100000000
);
@ -78,6 +59,7 @@ BEGIN # construct continued fraction representations of rational numbers #
print( ( newline, newline ) );
show r2cf( "Running for root2 :", sqrt2 );
print( ( newline, newline ) );
show r2cf( "Running for pi :", pi )
show r2cf( "Running for pi :", pif );
print( ( newline ) )
END
END

126
Task/Continued-fraction-Arithmetic-G-matrix-ng-continued-fraction-n-/FreeBASIC/continued-fraction-arithmetic-g-matrix-ng-continued-fraction-n-.basic Normal file
View file

@ -0,0 +1,126 @@
Type NG
As Integer a1, a, b1, b
Declare Constructor(a1 As Integer, a As Integer, b1 As Integer, b As Integer)
Declare Sub ingress(n As Integer)
Declare Function needterm() As Integer
Declare Function egress() As Integer
Declare Function egress_done() As Integer
Declare Function done() As Integer
End Type
Constructor NG(a1 As Integer, a As Integer, b1 As Integer, b As Integer)
This.a1 = a1
This.a = a
This.b1 = b1
This.b = b
End Constructor
Sub NG.ingress(n As Integer)
Dim As Integer temp_a = This.a
This.a = This.a1
This.a1 = temp_a + This.a1 * n
Dim As Integer temp_b = This.b
This.b = This.b1
This.b1 = temp_b + This.b1 * n
End Sub
Function NG.needterm() As Integer
If (This.b = 0 Or This.b1 = 0) Then Return True
If Not ((This.a \ This.b) = (This.a1 \ This.b1)) Then Return True
Return False
End Function
Function NG.egress() As Integer
Dim As Integer n = This.a \ This.b
Dim As Integer temp_a = This.a
This.a = This.b
This.b = temp_a - This.b * n
Dim As Integer temp_a1 = This.a1
This.a1 = This.b1
This.b1 = temp_a1 - This.b1 * n
Return n
End Function
Function NG.egress_done() As Integer
If This.needterm() Then
This.a = This.a1
This.b = This.b1
End If
Return This.egress()
End Function
Function NG.done() As Integer
Return (This.b = 0 And This.b1 = 0)
End Function
Function divmod(n1 As Integer, n2 As Integer) As Integer Ptr
Static result(1) As Integer
result(0) = n1 \ n2
result(1) = n1 Mod n2
Return @result(0)
End Function
Function r2cf(n1 As Integer, n2 As Integer) As Integer Ptr
Static result(99) As Integer
Dim As Integer cnt = 0
While n2 <> 0
Dim As Integer Ptr t1_n2 = divmod(n1, n2)
n1 = n2
n2 = t1_n2[1]
result(cnt) = t1_n2[0]
cnt += 1
Wend
result(cnt) = -1 ' Mark end of array
Return @result(0)
End Function
' Test cases
Type TestCase
Dim As String expr
Dim As Integer a1, a, b1, b, r1, r2
Declare Constructor()
Declare Constructor(e As String, _a1 As Integer, _a As Integer, _b1 As Integer, _b As Integer, _r1 As Integer, _r2 As Integer)
End Type
Constructor TestCase(e As String, _a1 As Integer, _a As Integer, _b1 As Integer, _b As Integer, _r1 As Integer, _r2 As Integer)
This.expr = e
This.a1 = _a1
This.a = _a
This.b1 = _b1
This.b = _b
This.r1 = _r1
This.r2 = _r2
End Constructor
Dim As TestCase tests(2) => { _
TestCase("[1;5,2] + 1/2", 2, 1, 0, 2, 13, 11), _
TestCase("[3;7] + 1/2", 2, 1, 0, 2, 22, 7), _
TestCase("[3;7] divided by 4", 1, 0, 0, 4, 22, 7) }
For i As Integer = 0 To 2
Print Right(Space(20) + tests(i).expr, 20); " -> ";
Dim op As NG = NG(tests(i).a1, tests(i).a, tests(i).b1, tests(i).b)
Dim As Integer Ptr cf = r2cf(tests(i).r1, tests(i).r2)
Dim As Integer j = 0
While cf[j] <> -1
If Not op.needterm() Then Print op.egress();
op.ingress(cf[j])
j += 1
Wend
Do
Print op.egress_done();
If op.done() Then Exit Do
Loop
Print
Next
Sleep

262
Task/Conways-Game-of-Life/AArch64-Assembly/conways-game-of-life.aarch64 Normal file
View file

@ -0,0 +1,262 @@
/* ARM assembly AARCH64 Raspberry PI 3B */
/* program Conway's Game of Life */
/*******************************************/
/* Constantes */
/*******************************************/
/* for this file see task include a file in language AArch64 assembly*/
.include "../includeConstantesARM64.inc"
.equ SIZE, 3
/*******************************************/
/* macros */
/*******************************************/
//.include "../../ficmacros64.inc" // for developper debugging
/*********************************/
/* Initialized data */
/*********************************/
.data
szMessDebutPgm: .asciz "Program 64 bits start. \n"
szCarriageReturn: .asciz "\n"
szMessFinOK: .asciz "Program normal end. \n"
/*********************************/
/* UnInitialized data */
/*********************************/
.bss
sAreaConv: .skip 24
startArea: .skip SIZE *SIZE
runArea: .skip SIZE *SIZE
.align 4
/*********************************/
/* code section */
/*********************************/
.text
.global main
main:
ldr x0,qAdrszMessDebutPgm
bl affichageMess // start message
ldr x0,qAdrstartArea
mov x1,1
mov x2,1
mov x3,0
mov x5,SIZE // init game
mul x4,x5,x2
strb w1,[x0,x4] // 1 in position 0,1
add x4,x4,1
strb w1,[x0,x4] // 1 in position 1,1
add x4,x4,1
strb w1,[x0,x4] // 1 in position 2,1
ldr x0,qAdrstartArea
bl displayGame
ldr x0,qAdrstartArea
ldr x1,qAdrrunArea
bl generer // generate new area game
ldr x0,qAdrrunArea
bl displayGame
ldr x0,qAdrrunArea
ldr x1,qAdrstartArea
bl generer // generate new area game
ldr x0,qAdrstartArea
bl displayGame
ldr x0,qAdrszMessFinOK
bl affichageMess
100:
mov x8,EXIT
svc #0 // system call
qAdrszMessDebutPgm: .quad szMessDebutPgm
qAdrszMessFinOK: .quad szMessFinOK
qAdrszCarriageReturn: .quad szCarriageReturn
qAdrsAreaConv: .quad sAreaConv
qAdrstartArea: .quad startArea
qAdrrunArea: .quad runArea
/******************************************************************/
/* display area game */
/******************************************************************/
/* x0 contains address area game */
/* x1 contains address result area */
generer:
stp x1,lr,[sp,-16]!
mov x6,x0
mov x9,x1
mov x7,SIZE
mov x4,0 // Y
1:
mov x5,0 // X
2:
mov x0,x6
mov x1,x5
mov x2,x4
bl computeCell // compute cell value
mul x8,x4,x7
add x8,x8,x5
ldrb w1,[x6,x8] // read status cell
mov x2,1
cmp x0,2 // 2 -> live
csel x0,x1,x0,eq
beq 3f
cmp x0,3 // 3 -> live or birth
csel x0,x2,x0,eq
beq 3f
mov x0,0 // else dead
3:
strb w0,[x9,x8] // store new status cell
add x5,x5,1
cmp x5,SIZE
blt 2b
add x4,x4,1
cmp x4,SIZE
blt 1b
100:
ldp x1,lr,[sp],16 // TODO: a completer
ret
/******************************************************************/
/* display area game */
/******************************************************************/
/* x0 contains address area game */
displayGame:
stp x1,lr,[sp,-16]!
mov x8,SIZE+2
lsr x8,x8,4
add x8,x8,1
lsl x8,x8,4
sub sp,sp,x8
mov fp,sp
mov x6,x0
mov x1,0
mov x3,SIZE
mov x7,'.'
mov x9,'X'
1:
mov x2,0
2:
mul x4,x1,x3
add x4,x4,x2
ldrb w5,[x6,x4]
cmp w5,0
csel x5,x7,x9,eq
strb w5,[fp,x2]
add x2,x2,1
cmp x2,SIZE
blt 2b
mov x5,'\n'
strb w5,[fp,x2]
add x2,x2,1
strb wzr,[fp,x2] // 0 final
mov x0,fp
bl affichageMess
add x1,x1,1
cmp x1,SIZE
blt 1b
ldr x0,qAdrszCarriageReturn
bl affichageMess
100:
add sp,sp,x8 // free reserved area
ldp x1,lr,[sp],16
ret
/******************************************************************/
/* compute cell score */
/******************************************************************/
/* x0 contains address game area */
/* x1 contains position X */
/* x2 contains position Y */
computeCell:
stp x1,lr,[sp,-16]!
stp x2,x3,[sp,-16]!
stp x4,x5,[sp,-16]!
stp x6,x7,[sp,-16]!
stp x8,x9,[sp,-16]!
mov x10,0 // score
mov x9,SIZE
cmp x2,0 // y =0
beq 2f
cmp x1,0 // x = 0
beq 1f
sub x3,x1,1 // pos X - 1
sub x4,x2,1 // pos Y -1
mul x5,x4,x9
add x5,x5,x3 // compute indice
ldrb w6,[x0,x5]
add x10,x10,x6
1:
mov x3,x1 // pos X pos y -1
sub x4,x2,1 // pos Y -1
mul x5,x4,x9
add x5,x5,x3 // compute indice
ldrb w6,[x0,x5]
add x10,x10,x6
cmp x1,SIZE-1
beq 2f
sub x4,x2,1 // pos Y -1
add x3,x1,1 // pos X+1 pos y -1
mul x5,x4,x9
add x5,x5,x3 // compute indice
ldrb w6,[x0,x5]
add x10,x10,x6
2:
cbz x1,3f
sub x3,x1,1
mov x4,x2 // pos X-1 pos y
mul x5,x4,x9
add x5,x5,x3 // compute indice
ldrb w6,[x0,x5]
add x10,x10,x6
3:
cmp x1,SIZE-1
beq 4f
add x3,x1,1
mov x4,x2 // pos X+1 pos y
mul x5,x4,x9
add x5,x5,x3 // compute indice
ldrb w6,[x0,x5]
add x10,x10,x6
4:
cmp x2,SIZE-1
beq 6f
cbz x1,5f
sub x3,x1,1
add x4,x2,1 // pos X-1 pos y+1
mul x5,x4,x9
add x5,x5,x3 // compute indice
ldrb w6,[x0,x5]
add x10,x10,x6
5:
mov x3,x1
add x4,x2,1 // pos X pos y+1
mul x5,x4,x9
add x5,x5,x3 // compute indice
ldrb w6,[x0,x5]
add x10,x10,x6
cmp x1,SIZE-1
beq 6f
add x3,x1,1
add x4,x2,1 // pos X+1 pos y+1
mul x5,x4,x9
add x5,x5,x3 // compute indice
ldrb w6,[x0,x5]
add x10,x10,x6
6:
mov x0,x10 // return total
100:
ldp x8,x9,[sp],16
ldp x6,x7,[sp],16
ldp x4,x5,[sp],16
ldp x2,x3,[sp],16
ldp x1,lr,[sp],16
ret
/***************************************************/
/* ROUTINES INCLUDE */
/***************************************************/
/* for this file see task include a file in language AArch64 assembly*/
.include "../includeARM64.inc"

1
Task/Count-in-factors/REXX/count-in-factors-3.rexx
View file

@ -33,4 +33,5 @@ say
return
include Numbers
include Sequences
include Functions

6
Task/Count-occurrences-of-a-substring/ALGOL-68/count-occurrences-of-a-substring.alg
View file

@ -1,7 +1,7 @@
PROC count string in string = (STRING needle, haystack)INT: (
INT start:=LWB haystack, next, out:=0;
FOR count WHILE string in string(needle, next, haystack[start:]) DO
start+:=next+UPB needle-LWB needle;
INT start pos:=LWB haystack, next, out:=0;
FOR count WHILE string in string(needle, next, haystack[start pos:]) DO
start pos+:=next+UPB needle-LWB needle;
out:=count
OD;
out

6
Task/Count-the-coins/Jq/count-the-coins.jq
View file

@ -4,7 +4,7 @@
def countcoins(target):
. as $coin
| reduce range(0; length) as $a
( [1]; # there is 1 way to make 0 cents
( [1] + [range(0, target)|0]; # there is 1 way to make 0 cents
reduce range(1; target + 1) as $b
(.; # total[]
if $b < $coin[$a] then .
@ -14,3 +14,7 @@ def countcoins(target):
end
end ) )
| .[target] ;
### Examples:
([1,5,10,25] | countcoins(100)),
([1, 5, 10, 25, 50, 100] | countcoins(100000))

15
Task/Count-the-coins/XPL0/count-the-coins.xpl0 Normal file
View file

@ -0,0 +1,15 @@
func CountCoins(M, N);
int M, N;
int Coins, Table, I, J;
[Coins:= [1, 5, 10, 25, 50, 100];
Table:= Reserve((N+1)*4);
for I:= 1 to N do Table(I):= 0;
Table(0):= 1;
for I:= 0 to M-1 do
for J:= Coins(I) to N do
Table(J):= Table(J) + Table(J-Coins(I));
return Table(N);
];
[IntOut(0, CountCoins(4, 100)); CrLf(0);
]

2
Task/Cuban-primes/REXX/cuban-primes-2.rexx
View file

@ -20,7 +20,7 @@ else
i = 2; a = 1; b = 8; n = 0
do while n < y
v = b-a
if IsPrime(v) then do
if Prime(v) then do
n = n+1
if n >= x then do
call Charout ,Right(v,z)

Some files were not shown because too many files have changed in this diff Show more