BEGIN DEF section of the program.
+
+=== Control Structures ===
+The ''[[Loops/For|for]]'' loop requires that both the start and end values be variables, constants, or literals; expressions are not permitted. The language does not implement a ''[[Loops/Do-while|repeat-until]]'' loop.
+
+=== Arithmetic Operations ===
+MoonRock 0.50 does not support [[Floating point|floating-point numbers]] and operations. Division using the / operator produces rounded [[Arithmetic/Integer|integer]] results. For integer division, the \ operator must be used. For example:
++0 +1 +1 ++The
MOD function is not implemented for 32-bit integers (doublewords).
+
+=== Comparison Operations ===
+Both operands in comparison operations must be literals, constants, or variables; expressions are not allowed. Only variables of the same type can be compared. Attempting to compare variables of different types, such as A& > B%, may produce incorrect results.
+
+=== Output ===
+To output the value of a named constant, it must be passed as an argument to the STR function:
+if and then are in lowercase. Conversely, the following formulation works regardless of case:
+T for TYPE, JM for JUMPMATCH). The only data types supported are strings and integers.
\ No newline at end of file
+Keywords—written in block capitals in the example above—are case-insensitive and can usually be abbreviated to one or two letters (T for TYPE, JM for JUMPMATCH). The only data types supported are strings and integers.
+=== External Links ===
+[https://handwiki.org/wiki/PILOT HandWiki PILOT], where you can find a list of PILOT implementations.
\ No newline at end of file
diff --git a/Lang/PL-I-80/Integer-overflow b/Lang/PL-I-80/Integer-overflow
new file mode 120000
index 0000000000..f1947b64b4
--- /dev/null
+++ b/Lang/PL-I-80/Integer-overflow
@@ -0,0 +1 @@
+../../Task/Integer-overflow/PL-I-80
\ No newline at end of file
diff --git a/Lang/PL-I/00-LANG.txt b/Lang/PL-I/00-LANG.txt
index e9ccbaa140..3b9ba57193 100644
--- a/Lang/PL-I/00-LANG.txt
+++ b/Lang/PL-I/00-LANG.txt
@@ -84,4 +84,8 @@ The pre-processor keywords are prefixed with a % (perce
==See Also==
* [[wp:PL/I|PL/I on Wikipedia]]
* [[PL/M]]
-* [[Polyglot:PL/I and PL/M]]
\ No newline at end of file
+* [[Polyglot:PL/I and PL/M]]
+
+==External links==
+* [http://teampli.net/index.html Team PL/I]
+** [http://teampli.net/candt.html PL/I Compilers and Tools]
\ No newline at end of file
diff --git a/Lang/PL-I/Abundant-odd-numbers b/Lang/PL-I/Abundant-odd-numbers
new file mode 120000
index 0000000000..666cd2c37f
--- /dev/null
+++ b/Lang/PL-I/Abundant-odd-numbers
@@ -0,0 +1 @@
+../../Task/Abundant-odd-numbers/PL-I
\ No newline at end of file
diff --git a/Lang/PL-I/Arithmetic-numbers b/Lang/PL-I/Arithmetic-numbers
new file mode 120000
index 0000000000..6912369ef9
--- /dev/null
+++ b/Lang/PL-I/Arithmetic-numbers
@@ -0,0 +1 @@
+../../Task/Arithmetic-numbers/PL-I
\ No newline at end of file
diff --git a/Lang/PL-I/Bell-numbers b/Lang/PL-I/Bell-numbers
new file mode 120000
index 0000000000..4afaf5b11f
--- /dev/null
+++ b/Lang/PL-I/Bell-numbers
@@ -0,0 +1 @@
+../../Task/Bell-numbers/PL-I
\ No newline at end of file
diff --git a/Lang/PL-I/Diversity-prediction-theorem b/Lang/PL-I/Diversity-prediction-theorem
new file mode 120000
index 0000000000..a449ec2ac9
--- /dev/null
+++ b/Lang/PL-I/Diversity-prediction-theorem
@@ -0,0 +1 @@
+../../Task/Diversity-prediction-theorem/PL-I
\ No newline at end of file
diff --git a/Lang/PL-I/Fairshare-between-two-and-more b/Lang/PL-I/Fairshare-between-two-and-more
new file mode 120000
index 0000000000..38f481a639
--- /dev/null
+++ b/Lang/PL-I/Fairshare-between-two-and-more
@@ -0,0 +1 @@
+../../Task/Fairshare-between-two-and-more/PL-I
\ No newline at end of file
diff --git a/Lang/PL-I/Tau-number b/Lang/PL-I/Tau-number
new file mode 120000
index 0000000000..3dade8db80
--- /dev/null
+++ b/Lang/PL-I/Tau-number
@@ -0,0 +1 @@
+../../Task/Tau-number/PL-I
\ No newline at end of file
diff --git a/Lang/PL-I/Zeckendorf-number-representation b/Lang/PL-I/Zeckendorf-number-representation
new file mode 120000
index 0000000000..eabc5808d1
--- /dev/null
+++ b/Lang/PL-I/Zeckendorf-number-representation
@@ -0,0 +1 @@
+../../Task/Zeckendorf-number-representation/PL-I
\ No newline at end of file
diff --git a/Lang/PL-M/Empty-program b/Lang/PL-M/Empty-program
new file mode 120000
index 0000000000..80a556ac57
--- /dev/null
+++ b/Lang/PL-M/Empty-program
@@ -0,0 +1 @@
+../../Task/Empty-program/PL-M
\ No newline at end of file
diff --git a/Lang/PL-M/Move-to-front-algorithm b/Lang/PL-M/Move-to-front-algorithm
new file mode 120000
index 0000000000..23bec2ef3f
--- /dev/null
+++ b/Lang/PL-M/Move-to-front-algorithm
@@ -0,0 +1 @@
+../../Task/Move-to-front-algorithm/PL-M
\ No newline at end of file
diff --git a/Lang/PL-M/Super-d-numbers b/Lang/PL-M/Super-d-numbers
new file mode 120000
index 0000000000..bb5c98f089
--- /dev/null
+++ b/Lang/PL-M/Super-d-numbers
@@ -0,0 +1 @@
+../../Task/Super-d-numbers/PL-M
\ No newline at end of file
diff --git a/Lang/PL-M/The-Twelve-Days-of-Christmas b/Lang/PL-M/The-Twelve-Days-of-Christmas
new file mode 120000
index 0000000000..a94c814e99
--- /dev/null
+++ b/Lang/PL-M/The-Twelve-Days-of-Christmas
@@ -0,0 +1 @@
+../../Task/The-Twelve-Days-of-Christmas/PL-M
\ No newline at end of file
diff --git a/Lang/PL-M/Zeckendorf-number-representation b/Lang/PL-M/Zeckendorf-number-representation
new file mode 120000
index 0000000000..3d48575a07
--- /dev/null
+++ b/Lang/PL-M/Zeckendorf-number-representation
@@ -0,0 +1 @@
+../../Task/Zeckendorf-number-representation/PL-M
\ No newline at end of file
diff --git a/Lang/Pascal-P/Abundant-deficient-and-perfect-number-classifications b/Lang/Pascal-P/Abundant-deficient-and-perfect-number-classifications
new file mode 120000
index 0000000000..248c55dcbd
--- /dev/null
+++ b/Lang/Pascal-P/Abundant-deficient-and-perfect-number-classifications
@@ -0,0 +1 @@
+../../Task/Abundant-deficient-and-perfect-number-classifications/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Abundant-odd-numbers b/Lang/Pascal-P/Abundant-odd-numbers
new file mode 120000
index 0000000000..745698036f
--- /dev/null
+++ b/Lang/Pascal-P/Abundant-odd-numbers
@@ -0,0 +1 @@
+../../Task/Abundant-odd-numbers/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Angle-difference-between-two-bearings b/Lang/Pascal-P/Angle-difference-between-two-bearings
new file mode 120000
index 0000000000..506fbb7a95
--- /dev/null
+++ b/Lang/Pascal-P/Angle-difference-between-two-bearings
@@ -0,0 +1 @@
+../../Task/Angle-difference-between-two-bearings/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Anti-primes b/Lang/Pascal-P/Anti-primes
new file mode 120000
index 0000000000..fe2e4f4a10
--- /dev/null
+++ b/Lang/Pascal-P/Anti-primes
@@ -0,0 +1 @@
+../../Task/Anti-primes/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Arithmetic-numbers b/Lang/Pascal-P/Arithmetic-numbers
new file mode 120000
index 0000000000..3ad1b31145
--- /dev/null
+++ b/Lang/Pascal-P/Arithmetic-numbers
@@ -0,0 +1 @@
+../../Task/Arithmetic-numbers/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Bell-numbers b/Lang/Pascal-P/Bell-numbers
new file mode 120000
index 0000000000..fccbe75006
--- /dev/null
+++ b/Lang/Pascal-P/Bell-numbers
@@ -0,0 +1 @@
+../../Task/Bell-numbers/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Brazilian-numbers b/Lang/Pascal-P/Brazilian-numbers
new file mode 120000
index 0000000000..f79a88ea27
--- /dev/null
+++ b/Lang/Pascal-P/Brazilian-numbers
@@ -0,0 +1 @@
+../../Task/Brazilian-numbers/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/CUSIP b/Lang/Pascal-P/CUSIP
new file mode 120000
index 0000000000..3a5ce6c0b7
--- /dev/null
+++ b/Lang/Pascal-P/CUSIP
@@ -0,0 +1 @@
+../../Task/CUSIP/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Catalan-numbers b/Lang/Pascal-P/Catalan-numbers
new file mode 120000
index 0000000000..9dee46f2ca
--- /dev/null
+++ b/Lang/Pascal-P/Catalan-numbers
@@ -0,0 +1 @@
+../../Task/Catalan-numbers/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Day-of-the-week b/Lang/Pascal-P/Day-of-the-week
new file mode 120000
index 0000000000..04c1bf395c
--- /dev/null
+++ b/Lang/Pascal-P/Day-of-the-week
@@ -0,0 +1 @@
+../../Task/Day-of-the-week/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Diversity-prediction-theorem b/Lang/Pascal-P/Diversity-prediction-theorem
new file mode 120000
index 0000000000..1c77b9f4a8
--- /dev/null
+++ b/Lang/Pascal-P/Diversity-prediction-theorem
@@ -0,0 +1 @@
+../../Task/Diversity-prediction-theorem/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Dot-product b/Lang/Pascal-P/Dot-product
new file mode 120000
index 0000000000..1354e110a2
--- /dev/null
+++ b/Lang/Pascal-P/Dot-product
@@ -0,0 +1 @@
+../../Task/Dot-product/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Ethiopian-multiplication b/Lang/Pascal-P/Ethiopian-multiplication
new file mode 120000
index 0000000000..cf25f4fb51
--- /dev/null
+++ b/Lang/Pascal-P/Ethiopian-multiplication
@@ -0,0 +1 @@
+../../Task/Ethiopian-multiplication/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Factors-of-an-integer b/Lang/Pascal-P/Factors-of-an-integer
new file mode 120000
index 0000000000..db1f886bee
--- /dev/null
+++ b/Lang/Pascal-P/Factors-of-an-integer
@@ -0,0 +1 @@
+../../Task/Factors-of-an-integer/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Gamma-function b/Lang/Pascal-P/Gamma-function
new file mode 120000
index 0000000000..b35d39ded3
--- /dev/null
+++ b/Lang/Pascal-P/Gamma-function
@@ -0,0 +1 @@
+../../Task/Gamma-function/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Generate-lower-case-ASCII-alphabet b/Lang/Pascal-P/Generate-lower-case-ASCII-alphabet
new file mode 120000
index 0000000000..54db5eb4c2
--- /dev/null
+++ b/Lang/Pascal-P/Generate-lower-case-ASCII-alphabet
@@ -0,0 +1 @@
+../../Task/Generate-lower-case-ASCII-alphabet/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Horners-rule-for-polynomial-evaluation b/Lang/Pascal-P/Horners-rule-for-polynomial-evaluation
new file mode 120000
index 0000000000..1bf2158b09
--- /dev/null
+++ b/Lang/Pascal-P/Horners-rule-for-polynomial-evaluation
@@ -0,0 +1 @@
+../../Task/Horners-rule-for-polynomial-evaluation/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Josephus-problem b/Lang/Pascal-P/Josephus-problem
new file mode 120000
index 0000000000..ee86f2f03c
--- /dev/null
+++ b/Lang/Pascal-P/Josephus-problem
@@ -0,0 +1 @@
+../../Task/Josephus-problem/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Leap-year b/Lang/Pascal-P/Leap-year
new file mode 120000
index 0000000000..e7c0275cd7
--- /dev/null
+++ b/Lang/Pascal-P/Leap-year
@@ -0,0 +1 @@
+../../Task/Leap-year/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Long-year b/Lang/Pascal-P/Long-year
new file mode 120000
index 0000000000..4a8c200f91
--- /dev/null
+++ b/Lang/Pascal-P/Long-year
@@ -0,0 +1 @@
+../../Task/Long-year/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Multifactorial b/Lang/Pascal-P/Multifactorial
new file mode 120000
index 0000000000..3a5245db30
--- /dev/null
+++ b/Lang/Pascal-P/Multifactorial
@@ -0,0 +1 @@
+../../Task/Multifactorial/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Periodic-table b/Lang/Pascal-P/Periodic-table
new file mode 120000
index 0000000000..d1e817f294
--- /dev/null
+++ b/Lang/Pascal-P/Periodic-table
@@ -0,0 +1 @@
+../../Task/Periodic-table/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Prime-decomposition b/Lang/Pascal-P/Prime-decomposition
new file mode 120000
index 0000000000..b9ce930a04
--- /dev/null
+++ b/Lang/Pascal-P/Prime-decomposition
@@ -0,0 +1 @@
+../../Task/Prime-decomposition/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Square-free-integers b/Lang/Pascal-P/Square-free-integers
new file mode 120000
index 0000000000..011a7d78bb
--- /dev/null
+++ b/Lang/Pascal-P/Square-free-integers
@@ -0,0 +1 @@
+../../Task/Square-free-integers/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal-P/Tau-number b/Lang/Pascal-P/Tau-number
new file mode 120000
index 0000000000..23629ebb6c
--- /dev/null
+++ b/Lang/Pascal-P/Tau-number
@@ -0,0 +1 @@
+../../Task/Tau-number/Pascal-P
\ No newline at end of file
diff --git a/Lang/Pascal/Abundant-odd-numbers b/Lang/Pascal/Abundant-odd-numbers
deleted file mode 120000
index b58a9a885b..0000000000
--- a/Lang/Pascal/Abundant-odd-numbers
+++ /dev/null
@@ -1 +0,0 @@
-../../Task/Abundant-odd-numbers/Pascal
\ No newline at end of file
diff --git a/Lang/PascalABC.NET/Arithmetic-numbers b/Lang/PascalABC.NET/Arithmetic-numbers
new file mode 120000
index 0000000000..91fbd5c07a
--- /dev/null
+++ b/Lang/PascalABC.NET/Arithmetic-numbers
@@ -0,0 +1 @@
+../../Task/Arithmetic-numbers/PascalABC.NET
\ No newline at end of file
diff --git a/Lang/PascalABC.NET/Attractive-numbers b/Lang/PascalABC.NET/Attractive-numbers
new file mode 120000
index 0000000000..974a121495
--- /dev/null
+++ b/Lang/PascalABC.NET/Attractive-numbers
@@ -0,0 +1 @@
+../../Task/Attractive-numbers/PascalABC.NET
\ No newline at end of file
diff --git a/Lang/PascalABC.NET/Pascals-triangle b/Lang/PascalABC.NET/Pascals-triangle
new file mode 120000
index 0000000000..1089718a97
--- /dev/null
+++ b/Lang/PascalABC.NET/Pascals-triangle
@@ -0,0 +1 @@
+../../Task/Pascals-triangle/PascalABC.NET
\ No newline at end of file
diff --git a/Lang/Perl/Machine-code b/Lang/Perl/Machine-code
new file mode 120000
index 0000000000..4729cd6042
--- /dev/null
+++ b/Lang/Perl/Machine-code
@@ -0,0 +1 @@
+../../Task/Machine-code/Perl
\ No newline at end of file
diff --git a/Lang/Perl/Prime-numbers-whose-neighboring-pairs-are-tetraprimes b/Lang/Perl/Prime-numbers-whose-neighboring-pairs-are-tetraprimes
new file mode 120000
index 0000000000..fc79cb9bd2
--- /dev/null
+++ b/Lang/Perl/Prime-numbers-whose-neighboring-pairs-are-tetraprimes
@@ -0,0 +1 @@
+../../Task/Prime-numbers-whose-neighboring-pairs-are-tetraprimes/Perl
\ No newline at end of file
diff --git a/Lang/Perl/Strassens-algorithm b/Lang/Perl/Strassens-algorithm
new file mode 120000
index 0000000000..013c3f70b0
--- /dev/null
+++ b/Lang/Perl/Strassens-algorithm
@@ -0,0 +1 @@
+../../Task/Strassens-algorithm/Perl
\ No newline at end of file
diff --git a/Lang/Perl/Tropical-algebra-overloading b/Lang/Perl/Tropical-algebra-overloading
new file mode 120000
index 0000000000..380da329d3
--- /dev/null
+++ b/Lang/Perl/Tropical-algebra-overloading
@@ -0,0 +1 @@
+../../Task/Tropical-algebra-overloading/Perl
\ No newline at end of file
diff --git a/Lang/Plain-English/00-LANG.txt b/Lang/Plain-English/00-LANG.txt
index b52aba7348..087f59b9fa 100644
--- a/Lang/Plain-English/00-LANG.txt
+++ b/Lang/Plain-English/00-LANG.txt
@@ -25,9 +25,10 @@ or compiled to a self-contained Microsoft Windows .exe file.
Here is a list of what you must understand from the start:
'''Fully Implemented in Itself:''' It is a single executable, with one or more human readable libraries (also written in Plain English Programming Language) which produces a new stand alone .exe with your new program in it.
-It is NOT a compiler only that takes in source and produces compiled code.
-It is NOT an IDE only, that shells out to a compiler.
-It is both.
+The project originally started as an IDE with a built-in compiler.
+Over time, this evolved into a separate effort, resulting in a standalone compiler developed as an independent project.
+Today, the ecosystem consists of two distinct components:
+an IDE that includes its own integrated compiler, and a separate command-line compiler, each maintained independently.
There is NO complete source code in another language; the system was bootstrapped in a Pascal-like language (which is no longer available) and was later re-written entirely in Plain English.
It is "Machine Code" Low Level: The bootstrap is very basic, only able to copy itself and add raw machine code in Intel hex format, make calls to the operating system, e.g.
+7
diff --git a/Task/A+B/VBScript/a+b-1.vbs b/Task/A+B/VBScript/a+b-1.vbs
new file mode 100644
index 0000000000..70ec9e210e
--- /dev/null
+++ b/Task/A+B/VBScript/a+b-1.vbs
@@ -0,0 +1,6 @@
+s=InputBox("Enter two numbers separated by a blank")
+t=Split(s)
+a=CInt(t(0))
+b=CInt(t(1))
+c=a+b
+MsgBox c
diff --git a/Task/A+B/VBScript/a+b-2.vbs b/Task/A+B/VBScript/a+b-2.vbs
new file mode 100644
index 0000000000..08f40b34e4
--- /dev/null
+++ b/Task/A+B/VBScript/a+b-2.vbs
@@ -0,0 +1,37 @@
+Option Explicit
+Dim a, b
+Select Case WScript.Arguments.Count
+ Case 0 'No arguments, prompt for them.
+ WScript.Echo "Enter values for a and b"
+ a = WScript.Stdin.ReadLine
+ if Instr(a, " ") > 0 then 'If two variables were passed
+ b = Split(a)(1)
+ a = Split(a)(0)
+ else
+ WScript.Echo "Enter value for b"
+ b = WScript.Stdin.ReadLine
+ end if
+ Case 1 'One argument, assume it's an input file, e.g. "in.txt"
+ Dim FSO : Set FSO = CreateObject("Scripting.FileSystemObject")
+ With FSO.OpenTextFile(WScript.Arguments(0), 1)
+ a = .ReadLine
+ b = Split(a)(1)
+ a = Split(a)(0)
+ .Close
+ End With
+ Case 2 'Two arguments, assume they are values
+ a = WScript.Arguments(0)
+ b = WScript.Arguments(1)
+End Select
+'At this point, a and b are strings as entered, make them numbers
+a = CInt(a)
+b = CInt(b)
+
+'Write the sum
+Wscript.Echo a + b
+if 1 = WScript.Arguments.Count then
+ With FSO.CreateTextFile("out.txt")
+ .WriteLine a + b
+ .Close
+ End With
+end if
diff --git a/Task/A+B/VHDL/a+b.vhd b/Task/A+B/VHDL/a+b.vhd
new file mode 100644
index 0000000000..5eea2b5c05
--- /dev/null
+++ b/Task/A+B/VHDL/a+b.vhd
@@ -0,0 +1,23 @@
+LIBRARY std;
+USE std.TEXTIO.all;
+
+
+entity test is
+end entity test;
+
+
+architecture beh of test is
+begin
+ process
+ variable line_in, line_out : line;
+ variable a,b : integer;
+ begin
+ readline(INPUT, line_in);
+ read(line_in, a);
+ read(line_in, b);
+
+ write(line_out, a+b);
+ writeline(OUTPUT, line_out);
+ wait; -- needed to stop the execution
+ end process;
+end architecture beh;
diff --git a/Task/ABC-problem/Ada/abc-problem.adb b/Task/ABC-problem/Ada/abc-problem.adb
new file mode 100644
index 0000000000..28ac345566
--- /dev/null
+++ b/Task/ABC-problem/Ada/abc-problem.adb
@@ -0,0 +1,78 @@
+with Ada.Characters.Handling;
+use Ada.Characters.Handling;
+
+
+package Abc is
+ type Block_Faces is array(1..2) of Character;
+ type Block_List is array(positive range <>) of Block_Faces;
+ function Can_Make_Word(W: String; Blocks: Block_List) return Boolean;
+end Abc;
+
+
+package body Abc is
+
+function Can_Make_Word(W: String; Blocks: Block_List) return Boolean is
+ Used : array(Blocks'Range) of Boolean := (Others => False);
+ subtype wIndex is Integer range W'First..W'Last;
+ wPos : wIndex;
+begin
+ if W'Length = 0 then
+ return True;
+ end if;
+ wPos := W'First;
+ while True loop
+ declare
+ C : Character := To_Upper(W(wPos));
+ X : constant wIndex := wPos;
+ begin
+ for I in Blocks'Range loop
+ if (not Used(I)) then
+ if C = To_Upper(Blocks(I)(1)) or C = To_Upper(Blocks(I)(2)) then
+ Used(I) := True;
+ if wPos = W'Last then
+ return True;
+ end if;
+ wPos := wIndex'Succ(wPos);
+ exit;
+ end if;
+ end if;
+ end loop;
+ if X = wPos then
+ return False;
+ end if;
+ end;
+ end loop;
+ return False;
+end Can_Make_Word;
+
+end Abc;
+
+with Ada.Text_IO, Ada.Strings.Unbounded, Abc;
+use Ada.Text_IO, Ada.Strings.Unbounded, Abc;
+
+procedure Abc_Problem is
+ Blocks : Block_List := (
+ ('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')
+ );
+ function "+" (S : String) return Unbounded_String renames To_Unbounded_String;
+ words : array(positive range <>) of Unbounded_String := (
+ +"A"
+ , +"BARK"
+ , +"BOOK"
+ , +"TREAT"
+ , +"COMMON"
+ , +"SQUAD"
+ , +"CONFUSE"
+ -- Border cases:
+ -- , +"CONFUSE2"
+ -- , +""
+ );
+begin
+ for I in words'Range loop
+ Put_Line ( To_String(words(I)) & ": " & Boolean'Image(Can_Make_Word(To_String(words(I)),Blocks)) );
+ end loop;
+end Abc_Problem;
diff --git a/Task/ABC-problem/COBOL/abc-problem.cob b/Task/ABC-problem/COBOL/abc-problem.cob
new file mode 100644
index 0000000000..7c1b0e20c6
--- /dev/null
+++ b/Task/ABC-problem/COBOL/abc-problem.cob
@@ -0,0 +1,64 @@
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. ABC-PROBLEM.
+
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 INPUT-DATA.
+ 03 BLOCK-SET PIC X(40) VALUE
+ 'BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM'.
+ 03 WORD-DATA.
+ 05 FILLER PIC X(7) VALUE 'A'.
+ 05 FILLER PIC X(7) VALUE 'BARK'.
+ 05 FILLER PIC X(7) VALUE 'BOOK'.
+ 05 FILLER PIC X(7) VALUE 'TREAT'.
+ 05 FILLER PIC X(7) VALUE 'COMMON'.
+ 05 FILLER PIC X(7) VALUE 'SQUAD'.
+ 05 FILLER PIC X(7) VALUE 'CONFUSE'.
+ 03 WORDS PIC X(7) OCCURS 7 TIMES, INDEXED BY W,
+ REDEFINES WORD-DATA.
+
+ 01 OUTPUT-LINE.
+ 03 OUT-WORD PIC X(7).
+ 03 FILLER PIC XX VALUE ': '.
+ 03 RESULT PIC X(3).
+ 03 FOO PIC 999.
+
+ 01 VARIABLES.
+ 03 BLOCK-SET PIC X(40).
+ 03 BLOCKS OCCURS 20 TIMES, INDEXED BY B,
+ REDEFINES BLOCK-SET.
+ 05 FACE-A PIC X.
+ 05 FACE-B PIC X.
+ 03 WORD.
+ 05 LETTERS PIC X OCCURS 7 TIMES, INDEXED BY L.
+ 03 FAIL-FLAG PIC X.
+ 88 FAILED VALUE 'X'.
+
+ PROCEDURE DIVISION.
+ BEGIN.
+ PERFORM CHECK-WORD VARYING W FROM 1 BY 1
+ UNTIL W IS GREATER THAN 7.
+ STOP RUN.
+
+ CHECK-WORD.
+ MOVE BLOCK-SET OF INPUT-DATA TO BLOCK-SET OF VARIABLES.
+
+ MOVE WORDS(W) TO WORD.
+ SET L TO 1.
+ MOVE SPACE TO FAIL-FLAG.
+ PERFORM CHECK-LETTER VARYING L FROM 1 BY 1
+ UNTIL FAILED
+ OR L IS GREATER THAN 7
+ OR LETTERS(L) IS EQUAL TO SPACE.
+
+ MOVE WORDS(W) TO OUT-WORD.
+ IF FAILED, MOVE 'NO' TO RESULT, ELSE MOVE 'YES' TO RESULT.
+ DISPLAY OUTPUT-LINE.
+
+ CHECK-LETTER.
+ SET B TO 1.
+ SEARCH BLOCKS VARYING B
+ AT END
+ MOVE 'X' TO FAIL-FLAG
+ WHEN LETTERS(L) IS EQUAL TO FACE-A(B) OR FACE-B(B)
+ MOVE SPACES TO BLOCKS(B).
diff --git a/Task/ABC-problem/Crystal/abc-problem.cr b/Task/ABC-problem/Crystal/abc-problem.cr
new file mode 100644
index 0000000000..5f3ec7d4ff
--- /dev/null
+++ b/Task/ABC-problem/Crystal/abc-problem.cr
@@ -0,0 +1,17 @@
+def can_make_word? (word, blocks, i=0)
+ return true if word.empty?
+ ch = word[0].upcase
+ blocks.each_with_index do |block, idx|
+ if ch.in? block.upcase
+ return true if can_make_word? word[1..], blocks[...idx] + blocks[(idx+1)..], i+1
+ end
+ end
+ false
+end
+
+blocks = "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM".split
+
+["A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE"].each do |word|
+ print word, " -> ", can_make_word?(word, blocks), "\n"
+end
+print "abba", " -> ", can_make_word?("abba", ["AB", "AB", "AC", "AC"]), "\n"
diff --git a/Task/ABC-problem/Euphoria/abc-problem.eu b/Task/ABC-problem/Euphoria/abc-problem.eu
new file mode 100644
index 0000000000..be5498a568
--- /dev/null
+++ b/Task/ABC-problem/Euphoria/abc-problem.eu
@@ -0,0 +1,35 @@
+include std/text.e
+
+sequence 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'}}
+sequence words = {"A","BarK","BOOK","TrEaT","COMMON","SQUAD","CONFUSE"}
+
+sequence current_word
+sequence temp
+integer matches
+
+for i = 1 to length(words) do
+ current_word = upper(words[i])
+ temp = blocks
+ matches = 0
+ for j = 1 to length(current_word) do
+ for k = 1 to length(temp) do
+ if find(current_word[j],temp[k]) then
+ temp = remove(temp,k)
+ matches += 1
+ exit
+ end if
+ end for
+ if length(current_word) = matches then
+ printf(1,"%s: TRUE\n",{words[i]})
+ exit
+ end if
+ end for
+ if length(current_word) != matches then
+ printf(1,"%s: FALSE\n",{words[i]})
+ end if
+end for
+
+if getc(0) then end if
diff --git a/Task/ABC-problem/PowerShell/abc-problem.ps1 b/Task/ABC-problem/PowerShell/abc-problem.ps1
new file mode 100644
index 0000000000..3c8a1239a4
--- /dev/null
+++ b/Task/ABC-problem/PowerShell/abc-problem.ps1
@@ -0,0 +1,117 @@
+<#
+.Synopsis
+ ABC Problem
+.DESCRIPTION
+ You are given a collection of ABC blocks. Just like the ones you had when you were a kid.
+ There are twenty blocks with two letters on each block. You are guaranteed to have a
+ complete alphabet amongst all sides of the blocks
+ blocks = "BO","XK","DQ","CP","NA","GT","RE","TG","QD","FS","JW","HU","VI","AN","OB","ER","FS","LY","PC","ZM"
+ The goal of this task is to write a function that takes a string and can determine whether
+ you can spell the word with the given collection of blocks.
+
+ The rules are simple:
+ 1.Once a letter on a block is used that block cannot be used again
+ 2.The function should be case-insensitive
+ 3. Show your output on this page for the following words:
+ >>> can_make_word("A")
+ True
+ >>> can_make_word("BARK")
+ True
+ >>> can_make_word("BOOK")
+ False
+ >>> can_make_word("TREAT")
+ True
+ >>> can_make_word("COMMON")
+ False
+ >>> can_make_word("SQUAD")
+ True
+ >>> can_make_word("CONFUSE")
+ True
+
+ Using the examples below you can either see just the value or
+ status and the values using the verbose switch
+
+.EXAMPLE
+ test-blocks -testword confuse
+
+.EXAMPLE
+ test-blocks -testword confuse -verbose
+
+#>
+
+function test-blocks
+{
+ [CmdletBinding()]
+ # [OutputType([int])]
+ Param
+ (
+ # word to test against blocks
+ [Parameter(Mandatory = $true,
+ ValueFromPipelineByPropertyName = $true)]
+ $testword
+
+ )
+
+ $word = $testword
+
+ #define array of blocks
+ [System.Collections.ArrayList]$blockarray = "BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS", "JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM"
+
+ #send word to chararray
+ $chararray = $word.ToCharArray()
+ $chars = $chararray
+
+ #get the character count
+ $charscount = $chars.count
+
+ #get the initial count of the blocks
+ $blockcount = $blockarray.Count
+
+ #find out how many blocks should be left from the difference
+ #of the blocks and characters in the word - 1 letter/1 block
+ $correctblockcount = $blockcount - $charscount
+
+ #loop through the characters in the word
+ foreach ($char in $chars)
+ {
+
+ #loop through the blocks
+ foreach ($block in $blockarray)
+ {
+
+ #check the current character against each letter on the current block
+ #and break if found so the array can reload
+ if ($char -in $block[0] -or $char -in $block[1])
+ {
+
+ write-verbose "match for letter - $char - removing block $block"
+ $blockarray.Remove($block)
+ break
+
+ }
+
+ }
+
+ }
+ #get final count of blocks left in array to determine if the word was
+ #correctly made
+ $finalblockcount = $blockarray.count
+ if ($finalblockcount -ne $correctblockcount)
+ {
+ write-verbose "$word : $false "
+ return $false
+ }
+ else
+ {
+ write-verbose "$word : $true "
+ return $true
+ }
+
+}
+
+#loop all the words and pass them to the function
+$wordlist = "a", "bark", "book", "treat", "common", "squad", "confuse"
+foreach ($word in $wordlist)
+{
+ test-blocks -testword $word -Verbose
+}
diff --git a/Task/ABC-problem/Rebol/abc-problem.rebol b/Task/ABC-problem/Rebol/abc-problem.rebol
new file mode 100644
index 0000000000..fe63851d8f
--- /dev/null
+++ b/Task/ABC-problem/Rebol/abc-problem.rebol
@@ -0,0 +1,38 @@
+Rebol [
+ title: "Rosetta code: ABC problem"
+ file: %ABC_problem.r3
+ url: https://rosettacode.org/wiki/ABC_problem
+ needs: 3.10.0 ;; or something like that
+ note: "Based on Red language solution"
+]
+;; Define the function 'test' that takes a string argument 's'
+test: function [s [string!]][
+ ;; Make a copy of the input string to work on (avoid mutation of original)
+ s: copy s
+ ;; Initialize 'p' as a copy of a specific character sequence
+ p: copy "BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM"
+ ;; Start an infinite loop
+ forever [
+ ;; If 's' is empty, return true (all characters matched/removed)
+ if 0 = length? s [return true]
+ ;; If 'p' is at the tail (all pairs tried), return false (no match)
+ if tail? p [return false]
+ ;; Create a parsing rule of the current two characters in 'p'
+ rule: reduce [first p '| second p]
+ ;; Try to parse 's' according to the current rule:
+ ;; If parsing succeeds, remove that rule from the string
+ p: either parse s [to rule remove rule to end ] [
+ ;; If parsing succeeded, remove the current pair from 'p'
+ head remove/part p 2
+ ][
+ ;; If parsing failed, skip the current pair in 'p' (move to next pair)
+ skip p 2
+ ]
+ ]
+]
+
+;; Test the 'test' function on each word split from a string (split by space).
+foreach word split {A bark book TrEAT COmMoN SQUAD conFUsE} space [
+ ;; Print the word and its result from 'test'
+ printf [8 ": "] reduce [word test word]
+]
diff --git a/Task/ABC-problem/Uiua/abc-problem.uiua b/Task/ABC-problem/Uiua/abc-problem.uiua
new file mode 100644
index 0000000000..244ecba154
--- /dev/null
+++ b/Task/ABC-problem/Uiua/abc-problem.uiua
@@ -0,0 +1,4 @@
+s ← "BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM"
+Flt ← ⊂⊙↘₂⊃↙↘-⊸◿2⊸˜⨂ # remove block holding letter
+{"A" "BARK" "BOOK" "TREAT" "COMMON" "SQUAD" "CONFUSE"}
+≡⊂⟜⍚(◌◌⍥(⍥(⊙⊙⋅0)⊸≍⟜˜Flt⊙°⊂)◡⋅⧻ s ⊙1)
diff --git a/Task/ABC-problem/V-(Vlang)/abc-problem.v b/Task/ABC-problem/V-(Vlang)/abc-problem.v
index cf760dbe08..f34fa80d4b 100644
--- a/Task/ABC-problem/V-(Vlang)/abc-problem.v
+++ b/Task/ABC-problem/V-(Vlang)/abc-problem.v
@@ -1,13 +1,12 @@
-const
-(
- blocks = ["BO","XK","DQ","CP","NA","GT","RE","TG","QD","FS","JW","HU","VI","AN","OB","ER","FS","LY","PC","ZM"]
- words = ["A", BARK","BOOK","TREAT","COMMON","SQUAD","CONFUSE"]
-)
+const blocks = ["BO","XK","DQ","CP","NA","GT","RE","TG","QD","FS",
+"JW","HU","VI","AN","OB","ER","FS","LY","PC","ZM"]
+
+const words = ["A", "BARK","BOOK","TREAT","COMMON","SQUAD","CONFUSE"]
fn main() {
for word in words {
println('>>> can_make_word("${word.to_upper()}"): ')
- if check_word(word, blocks) == true {println('True')} else {println('False')}
+ if check_word(word, blocks) == true { println("True") } else { println("False") }
}
}
@@ -18,12 +17,12 @@ fn check_word(word string, blocks []string) bool {
found = false
for idx, _ in tblocks {
if tblocks[idx].contains(chr.ascii_str()) == true {
- tblocks[idx] =''
+ tblocks[idx] =""
found = true
break
}
}
- if found == false {return found}
+ if found == false { return found }
}
return found
}
diff --git a/Task/ABC-problem/Zig/abc-problem.zig b/Task/ABC-problem/Zig/abc-problem.zig
new file mode 100644
index 0000000000..ea586f7323
--- /dev/null
+++ b/Task/ABC-problem/Zig/abc-problem.zig
@@ -0,0 +1,54 @@
+const std = @import("std");
+
+const Block: type = struct { Char1: u8, Char2: u8 };
+const BLOCK_SIZE: comptime_int = 20;
+const blocks: [BLOCK_SIZE]Block = .{
+ .{ .Char1 = 'B', .Char2 = 'O' }, .{ .Char1 = 'X', .Char2 = 'K' },
+ .{ .Char1 = 'D', .Char2 = 'Q' }, .{ .Char1 = 'C', .Char2 = 'P' },
+ .{ .Char1 = 'N', .Char2 = 'A' }, .{ .Char1 = 'G', .Char2 = 'T' },
+ .{ .Char1 = 'R', .Char2 = 'E' }, .{ .Char1 = 'T', .Char2 = 'G' },
+ .{ .Char1 = 'Q', .Char2 = 'D' }, .{ .Char1 = 'F', .Char2 = 'S' },
+ .{ .Char1 = 'J', .Char2 = 'W' }, .{ .Char1 = 'H', .Char2 = 'U' },
+ .{ .Char1 = 'V', .Char2 = 'I' }, .{ .Char1 = 'A', .Char2 = 'N' },
+ .{ .Char1 = 'O', .Char2 = 'B' }, .{ .Char1 = 'E', .Char2 = 'R' },
+ .{ .Char1 = 'F', .Char2 = 'S' }, .{ .Char1 = 'L', .Char2 = 'Y' },
+ .{ .Char1 = 'P', .Char2 = 'C' }, .{ .Char1 = 'Z', .Char2 = 'M' },
+};
+
+fn can_make_word(word: []const u8) bool {
+ var marked: [BLOCK_SIZE]bool = [_]bool{false} ** BLOCK_SIZE;
+
+ for (word) |char| {
+ var hasBlock: bool = false;
+
+ for (blocks, 0..) |block, index| {
+ if ((block.Char1 == char or block.Char2 == char) and !marked[index]) {
+ hasBlock = true;
+ marked[index] = true;
+ break;
+ }
+ }
+
+ if (!hasBlock) {
+ return false;
+ }
+ }
+
+ return true;
+}
+
+pub fn main() !void {
+ const words: []const []const u8 = &.{
+ "A",
+ "BARK",
+ "BOOK",
+ "TREAT",
+ "COMMON",
+ "SQUAD",
+ "CONFUSE",
+ };
+
+ for (words) |word| {
+ std.debug.print("{s}\t{any}\n", .{ word, can_make_word(word) });
+ }
+}
diff --git a/Task/ADFGVX-cipher/APL/adfgvx-cipher.apl b/Task/ADFGVX-cipher/APL/adfgvx-cipher.apl
new file mode 100644
index 0000000000..93c8c07787
--- /dev/null
+++ b/Task/ADFGVX-cipher/APL/adfgvx-cipher.apl
@@ -0,0 +1,39 @@
+adfgvx←{
+ n←⎕NS''
+ n.split←↑{⍺≥⍴⍵:⊂⍵ ⋄ (⊂⍺↑⍵),⍺∇⍺↓⍵}
+
+ n.enc←⍺{
+ t←∊(∘.,⍨'ADFGVX')[⊃∘⍸∘(⍺⍺∘=)¨⍵]
+ w←↓⍉((⍴⍵⍵)split t)[;⍋⍵⍵]
+ 1↓∊' ',¨w~¨' '
+ }⍵
+
+ n.dec←⍺{
+ t←↓2 split (∊(⍉↑⍵⊆⍨' '≠⍵)[;⍋⍋⍵⍵])~' '
+ ⍺⍺['ADFGVX'∘⍳¨t]
+ }⍵
+
+ n
+}
+
+adfgvx_test←{
+ square←6 6⍴(⎕A,⎕D)[?⍨36]
+ ⎕←'Polybius square:'
+ ⎕←' ─ADFGVX','│┼││││││','A D F G V X' ⍪'─'⍪(11⍴1 0)\square
+ ⎕←''
+
+ key←{
+ file←'e:\unixdict.txt'
+ dict←(~data∊⎕TC)⊆data←⊃⎕NGET file
+ dict←(⍵{⍺=≢⍵}¨dict)/dict
+ dict←({⍵≡∪⍵}¨dict)/dict
+ 1⎕C ⊃dict[?⍴dict]
+ }9
+ ⎕←'Key: ',key
+
+ a←square adfgvx key
+
+ ⎕←'Plaintext: ',plaintext←'ATTACKAT1200AM'
+ ⎕←'Encrypted: ',encrypted←a.enc plaintext
+ ⎕←'Decrypted: ',a.dec encrypted
+}
diff --git a/Task/ADFGVX-cipher/Crystal/adfgvx-cipher.cr b/Task/ADFGVX-cipher/Crystal/adfgvx-cipher.cr
new file mode 100644
index 0000000000..3236abc45a
--- /dev/null
+++ b/Task/ADFGVX-cipher/Crystal/adfgvx-cipher.cr
@@ -0,0 +1,62 @@
+def make_square
+ # it's a square at heart...
+ (('A'..'Z').to_a + ('0'..'9').to_a).shuffle!
+end
+
+def make_key (size)
+ words = File.open("unixdict.txt") do |f|
+ f.each_line.select {|w| w.size == size && w.chars.to_set.size == size }.to_a
+ end
+ raise "no suitable key found" if words.empty?
+ words.sample
+end
+
+def adfgvx_encrypt (message, square, key)
+ h = "ADFGVX".chars
+ message.chars.flat_map {|ch|
+ row, col = square.index!(ch).divmod(6)
+ [ h[row], h[col] ]
+ }
+ .in_groups_of(key.size)
+ .transpose
+ .zip(key.chars)
+ .sort_by {|_, key| key }
+ .map {|col, _| col.join }
+ .join(" ")
+end
+
+def adfgvx_decrypt (message, square, key)
+ h = "ADFGVX".chars
+ sorted_key = key.chars.sort!
+ cols = message.split.map &.chars
+ max_size = cols.max_of &.size
+ cols.map {|col| col + [nil]*(max_size-col.size) }
+ .zip(sorted_key)
+ .sort_by {|_, ch| key.index! ch }
+ .map {|col, _| col }
+ .transpose
+ .flatten.compact
+ .in_slices_of(2)
+ .map {|(row, col)| square[ h.index!(row)*6 + h.index!(col) ] }
+ .join
+end
+
+def show (title, message, square, key)
+ encrypted = adfgvx_encrypt message, square, key
+ decrypted = adfgvx_decrypt encrypted, square, key
+ puts title
+ puts " - Alphabet: #{square.join}"
+ puts " - Key: #{key}"
+ puts " - Message: #{message}"
+ puts " - Encrypted: #{encrypted}"
+ puts " - Decrypted: #{decrypted}"
+ puts
+end
+
+message = "ATTACKAT1200AM"
+
+wiki_square = "NA1C3H8TB2OME5WRPD4F6G7I9J0KLQSUVXYZ".chars
+wiki_key = "PRIVACY"
+
+show "Wikipedia example:", message, wiki_square, wiki_key
+show "Random square and key:", message, make_square, make_key(9)
diff --git a/Task/ADFGVX-cipher/Fortran/adfgvx-cipher.f b/Task/ADFGVX-cipher/Fortran/adfgvx-cipher.f
new file mode 100644
index 0000000000..40af143af8
--- /dev/null
+++ b/Task/ADFGVX-cipher/Fortran/adfgvx-cipher.f
@@ -0,0 +1,618 @@
+!
+! ADFGVX Cipher
+! tested with Intel ifx (IFX) 2025.2.1 20250806 on Kubuntu 25.10
+! GNU Fortran (Ubuntu 15.2.0-4ubuntu4) 15.2.0 on Kubuntu 25.10
+! VSI Fortran on VMS does not compile it because it cannot handle
+! allocatable character strings.
+! U.B., December 2025
+!==============================================================================
+
+program ADFGVXCipher
+
+ implicit none
+
+ logical, parameter :: DEBUG = .false. ! set to .true. for reproducable, not random results
+ logical, parameter :: VERBOSE = .false. ! set this to .true. to print some intermediate results
+ integer, parameter :: maxLen=100 ! Maximum length of any test message (including extensions as 'X')
+
+ integer, parameter :: minPassLen=7, maxPassLen=12 ! Minimum and maximum password length
+
+ ! The complete alphabet of capital letters as used in most western languages, plus numbers 0...9
+ character (len=36), parameter :: Alphabet ='ABCDEFGHIJKLMNOPQRSTUVWXYZ01234567879'
+ character (len=*), parameter :: ADFGVX = 'ADFGVX'
+
+ character (len=maxLen) :: MsgToEncrypt, DecryptedMsg
+ character (len=2*maxLen) :: EncryptedMsg ! encrypt makes 2 letters from 1
+ character (len=25) :: PassPhrase
+ integer, parameter :: ColWidth = 6 ! depends on length of the used alphabet but we use only 36 letters
+
+ character (len=36) :: PolyAlphabet ! Permutation of Alphabet to represent Polybius square
+ integer :: i
+
+ ! Initialize random number generator once for the entire run-time of the program and all test cases
+ call random_seed()
+
+
+ ! The message to encrypt - for 1 test case
+ ! the plain text message is from the task description
+ MsgToEncrypt = 'ATTACKAT1200AM'
+
+ if (.not. DEBUG) then
+ print '("Init: DEBUG is .false., i.e. password and Polybius square are randomized.")'
+ PassPhrase = getRandomPassPhrase() ! select random password from unixdict.txt
+ else
+ ! for DEBUG only: force constant password for reproducible result:
+ print '("Init: DEBUG is .true., i.e. the code reproduces results of the NIM solution")'
+ PassPhrase = 'EXCURSION' ! Taken from the NIM solution
+ endif
+
+ print '("Init: PassPhrase for encode and decode is ", A)' , PassPhrase
+
+ if (.not. DEBUG) then
+ call createRandomPolybiusSquare () ! Create random Permutation of Alphabet to represent Polybius square
+ else
+ ! For DEBUG only: force constant string for reproducable results
+ ! Both the Alphabet and the password are from the NIM solution.
+ ! If DEBUG is .true., the result of the NIM solution is exactly reproduced.
+ PolyAlphabet = 'XOFPD6VHC40ZJMKRU5IA9YBW3L21NGQTE78S'
+ endif
+
+ call PrintSquare ("Init: Following Polybius square is used for encode/decode:", PolyAlphabet, ColWidth)
+
+ call encode (MsgToEncrypt , EncryptedMsg, PolyAlphabet, PassPhrase)
+ call decode (EncryptedMsg, DecryptedMsg, PolyAlphabet, PassPhrase)
+
+ call printResult (MsgToEncrypt, EncryptedMsg, DecryptedMsg)
+
+contains
+
+
+
+! ==========================================================
+! Find random length of the new password,
+! then pick a random word of this length from the word list
+! ==========================================================
+function getRandomPassPhrase() result (retval)
+ character (len=maxPassLen) :: retval
+ integer :: leng ! required length of password to pick
+
+ leng = randominInterval (minPassLen, maxPassLen)
+ retval = getRandomWord (leng)
+
+end function getRandomPassPhrase
+
+! ==================================================================================
+! Read the wordlist unixdict.txt and select a random word with the requested length
+! ==================================================================================
+function getRandomWord (leng) result (retval)
+ integer, intent(in) :: leng
+ character (len=maxPassLen) :: retval
+
+ character(len=100) :: word ! is longer than expected input word length
+ character (len=maxPassLen), allocatable :: Candidates (:)
+ integer:: capacity, content
+ integer :: io_stat, l, idx, ii
+
+ ! Read all words from unixdict.txt having length "len" and no repeating letters
+ open(unit=10, file='unixdict.txt', status='old', action='read', iostat=io_stat)
+ if (io_stat .ne. 0) then ! File open MUST be successful, otherwise total program failure.
+ print *, "Error opening file"
+ stop
+ end if
+ capacity = 128
+ call resize (Candidates, maxPassLen, capacity)
+ content = 0
+ do
+ read (10,'(A)', iostat=io_stat) word ! ok for both intel and GNU.
+ l = len_trim (word) ! use this instead of Q format
+ if (io_stat < 0) exit ! EOF: Normal end of this loop
+ if (io_stat > 0) then
+ print *, "Read error" ! ERROR: (never seen)
+ exit
+ end if
+ if (l .ne. leng) cycle
+ if (hasDuplicateChars(word)) cycle
+ if (content .eq. capacity) then
+ capacity = capacity * 2
+ call resize (Candidates, maxPassLen, capacity)
+ end if
+ content = content + 1
+ Candidates (content) = word
+ enddo
+ idx = randominInterval (1, content)
+ retval = candidates (idx)
+ do ii=1, leng
+ if (retval(ii:ii) .ge. 'a' .and. retval(ii:ii) .le. 'z') then
+ retval(ii:ii) = char (ichar(retval(ii:ii)) - ichar('a') + ichar('A'))
+ endif
+ end do
+ close (10)
+
+end function getRandomWord
+
+! ========================================================================
+! Return true if argument word contains duplicate letters, otherwise false.
+! ========================================================================
+function hasDuplicateChars (word) result (itHas)
+ character (len=*), intent(in) :: word
+ logical :: itHas
+ integer :: ii, jj, l
+ l = len_trim(word)
+ do ii=1, l
+ do jj=ii+1, l
+ if (word(ii:ii) .eq. word(jj:jj)) then
+ itHas = .true.
+ return
+ endif
+ end do
+ end do
+ itHas = .false.
+end function hasDuplicateChars
+
+
+ !==============================================================
+ ! Creating a random Polybius square is equivalent with creating
+ ! a random permutation of the used alphabet
+ ! Use the Sattolo algorithm to create such a permutation .
+ !==============================================================
+subroutine createRandomPolybiusSquare ()
+
+ character :: tmp ! for swapping single letters
+
+ integer :: j, k, l ! Helper variables: indices into words, words' length
+
+
+ PolyAlphabet = Alphabet
+ l = len (Alphabet)
+ do j = l, 1, -1 ! For all letters from end down to begin
+ k = randominInterval (1, j-1) ! Select random letters between 1 and j-1
+ tmp = PolyAlphabet(j:j) ! then swap letter at pos j with letter at pos k
+ PolyAlphabet (j:j) = PolyAlphabet (k:k)
+ PolyAlphabet (k:k) = tmp
+ end do
+
+end subroutine createRandomPolybiusSquare
+
+
+
+! =============================================
+! Increase allocated size of string array 'var'
+! =============================================
+subroutine resize(var, sLen, newSize)
+ integer, intent(in) :: sLen ! LEngth of 1 element of string array
+ character (len=sLen), allocatable, intent(inout) :: var(:) ! The array to be increased
+ integer, intent(in) :: newSize ! The new size of var
+ character (len=sLen), allocatable :: tmp(:) ! Temporary storage
+ integer :: oldSize ! Current array size
+ integer :: ii ! Loop index
+
+ ! Copy allocated values to temporary, then allocate var with
+ ! new size and copy back saved values.
+ ! Could be done with move_alloc but this would not be portable to OpenVMS Fortran
+
+ if (allocated(var)) then
+ oldSize = size(var)
+ else
+ oldSize = 0
+ end if
+
+ if (newSize .gt. oldSize) then ! only increment
+ if (oldSize .gt.0) then
+ allocate(tmp (oldSize))
+ tmp(:oldSize) = var(:oldSize)
+ deallocate (var)
+ end if
+ allocate(var(newSize))
+ if (allocated(tmp) .and. allocated (var) ) then
+ oldSize = min(size(tmp, 1), size(var, 1))
+ var(:oldSize) = tmp(:oldSize)
+ deallocate (tmp)
+ end if
+ end if
+end subroutine resize
+
+
+ ! ===========================================================
+ ! Generate random number between @lo and @hi (inclusive)
+ ! Assume Random Number Generator has been initialized before.
+ ! ===========================================================
+function randominInterval (lo, hi) result (r)
+ integer, intent(in) :: lo, hi ! the interval
+ integer :: r ! resultant (pseudo-)random number
+ real :: rnd ! Fortran random number generator generates float values
+
+ call random_number (rnd)
+ r = lo + FLOOR((hi+1-lo)*rnd) ! We want to choose one between [lo,hi]
+
+end function randominInterval
+
+
+
+! =============================================
+! Encode a given string using the ADFGVX Cipher
+! =============================================
+subroutine encode (argInString, outString, argAlphabet, argPassPhrase)
+ character (len=*), intent(in) :: argInString ! The string to encode
+ character (len=*), intent(out) :: outString ! The resultant encoded text
+ character (len=*), intent(in) :: argAlphabet ! The alphabet that makes the Polybius square
+ character (len=*), intent(in) :: argPassPhrase ! the password used for encode and also decode.
+ integer :: nRow
+ integer :: argLen, passLen, newlen, ii, jj, kk, row, col
+ character(len=2*len(OutString)+len_trim(argPassPhrase)) newAlphabet
+
+ character, dimension(:,:), allocatable :: Matrix, expandedMatrix
+
+ argLen = len_trim (argInString)
+ passLen = len_trim (argPassPhrase)
+ newlen = len(OutString)+len_trim(argPassPhrase)
+ ! 1st step: encode with the given alphabet (resp. the equivalent 6x6 square),
+ ! the output string being the row/col of each letter, expressed in terms of ADFGVX
+ outString = ' '
+ jj = 1
+ do ii=1,argLen
+ call getRC (argInString(ii:ii),row,col, argAlphabet)
+ outString (jj:jj) = ADFGVX (row:row)
+ jj = jj + 1
+ outString (jj:jj) = ADFGVX (col:col)
+ jj = jj + 1
+ end do
+
+ if (VERBOSE) then
+ print '("Encode, first step: ")'
+ do ii=1, arglen
+ write (*,'(A3)', advance='no') ArgInString (ii:ii)
+ end do
+ print *, 'becomes'
+
+ do ii=1, 2*argLen, 2
+ write (*,'(x,A2)', advance='no') outString (ii:ii+1)
+ end do
+ write (*,'(///)')
+ endif
+
+ jj = 1
+ kk = 1
+ newAlphabet = argPassPhrase (:passLen) // outString(:len_trim(outString))
+
+ nRow = (len_trim (newAlphabet) + passLen - 1)/passLen ! Required net number of lines for the Matrix
+ allocate (Matrix (passLen, nRow))
+
+ ! Without any complications: Just accept that last line might be incomplete - complete it with spaces.
+ do row=1, nRow
+ do col=1,passLen
+ if (row .eq. 1 ) then ! Top row gets the password
+ Matrix (col,row) = newAlphabet (jj:jj)
+ jj = jj + 1
+ else
+ if (jj .gt. len_trim(newAlphabet)) then ! Entire new alphabet copied to Matrix
+ Matrix(col,row) = ' ' ! remaining Matrix is all blank
+ else
+ Matrix (col,row) = newAlphabet (jj:jj)
+ jj = jj + 1
+ endif
+ endif
+ end do
+ if (jj .gt. len_trim(newAlphabet)) exit
+ end do
+ jj = 1
+ do row=1, nRow
+ do col=1,passLen
+ newAlphabet (jj:jj) = Matrix (col,row)
+ jj = jj + 1
+ end do
+ end do
+
+ if (VERBOSE) &
+ call printMatrix ('Encode: This results in a new matrix: ', Matrix, nRow, passLen)
+ ! Sort columns
+ call quicksort_matrix (Matrix, passLen, nRow, 1, passlen)
+
+ if (VERBOSE) &
+ call printMatrix ('Encode: After sorting columns, this becomes: ', Matrix, nRow, passLen)
+
+ jj = 1
+ do row=1, nRow
+ do col=1,passLen
+ newAlphabet (jj:jj) = Matrix (col,row)
+ jj = jj + 1
+ end do
+ end do
+
+ allocate (expandedMatrix (passLen, nRow))
+ ! Initialize al to blank
+ do row=1, 2*kk
+ do col=1,passLen
+ expandedMatrix (col,row) = ' '
+ end do
+ end do
+
+ jj=1
+ do row=1, nRow
+ do col=1,passLen
+ if (jj .le. len_trim(newAlphabet)) then
+ expandedMatrix (col,row) = newAlphabet (jj:jj)
+ else
+ expandedMatrix (col,row) = ' '
+ endif
+ jj = jj + 1
+ end do
+ end do
+
+ outString = ' '
+ jj = 1
+ do col=1,passLen
+ do row=2, nRow
+ if (expandedMatrix (col,row) .ne. ' ') then
+ outString (jj:jj) = expandedMatrix (col,row)
+ jj = jj + 1
+ end if
+ end do
+ outString (jj:jj) = ' '
+ jj = jj + 1
+ end do
+
+end subroutine encode
+
+
+! ==================================================================================
+! Sort columns of a Matrix, taking elements of top row as key to decide "lt" or ge".
+! ==================================================================================
+recursive subroutine quicksort_matrix (mat, ncols, nrows, low, high)
+
+ integer, intent(in) :: ncols,nrows
+ character, dimension (ncols,nrows), intent(inout) :: mat
+
+ integer, intent(in) :: low, high
+ integer :: pivot_index
+ integer :: i, j, mid
+ character :: pivot, temp
+
+ if (low .lt. high) then
+ ! The list is already "almost sorted", so use midlle word as pivot.
+ mid = low + (high-low) / 2
+ pivot = mat (mid,1)
+
+ !Move pivot to the end
+ call swapMat (mat,ncols,nrows,mid,high)
+
+ i = low - 1
+ do j = low, high - 1
+ if (mat(j,1) .le. pivot) then
+ i = i + 1
+ call swapMat (mat,ncols,nrows,i,j)
+ end if
+ end do
+
+ call swapMat (mat,ncols,nrows,i+1,high)
+ pivot_index = i + 1
+
+ call quicksort_matrix (mat, ncols,nrows, low, pivot_index - 1)
+ call quicksort_matrix (mat, ncols,nrows, pivot_index + 1, high)
+ end if
+end subroutine quicksort_matrix
+
+! ===============================================
+! Swap two columns of a Matrix (Used for sorting)
+! ===============================================
+subroutine swapMat (mat,ncols,nrows,col1,col2)
+ integer, intent(in) :: ncols,nrows ! Size of ...
+ character, dimension (ncols,nrows), intent(inout) :: mat ! ... the matrix
+ integer, intent(in) :: col1, col2 ! The 2 columns to swap
+
+ character :: tmp ! Helpers to swap 2 elements
+ integer :: row
+
+ ! early return in trivial noop case
+ if (col1 .eq. col2) return
+
+ do row=1, nrows ! Swap all elements of col 1 and col 2
+ tmp = mat (col1,row)
+ mat (col1,row) = mat(col2,row)
+ mat(col2,row) = tmp
+ end do
+
+end subroutine swapMat
+
+! =======================================================
+! Decode a given (encoded) string using the ADFGVX Cipher
+! =======================================================
+subroutine decode (argInString, outString, argAlphabet, argPassPhrase)
+ character (len=*), intent(in) :: argInString ! The encoded string to decode
+ character (len=*), intent(out) :: outString ! Result of the decode
+ character (len=*), intent(in) :: argAlphabet ! The Polybius Square to encode and decode
+ character (len=*), intent(in) :: argPassPhrase ! The Password used to encode and decode
+ character (len=MaxLen) :: tmpString ! Temporary torage for intermediate result
+ character, allocatable :: Matrix (:,:) ! Matrix to constructed from input string
+ character (len=:),allocatable :: SortedPassPhrase ! The password after sorting its letters
+ integer :: nRow, passLen ! NMUmbner of rows and columns of above Matrix
+ integer :: inLen, col,row, ii, jj, idx ! Length of input string, and some helpers
+
+ ! Estimate input string lengths
+ inLen = len_trim (argInString)
+ passLen = len_trim (argPassPhrase)
+
+ outString = ' '
+ nRow = (inLen + (passLen-1)) / passLen + 1 ! 1 extra for top row = password
+
+ allocate (Matrix (passLen, nRow))
+
+ ! Initialize entire matrix
+ do col=1,passLen
+ do row=1, nRow
+ Matrix (col,row) = ' '
+ end do
+ ! Fill the column as far as required
+ end do
+
+
+ ! The columns of the result matrix are sorted as password letters and
+ ! the sorted password letters makeup top row of th is matrix
+ SortedPassPhrase = argPassPhrase
+ call quicksort_matrix (SortedPassPhrase, passlen, 1, 1, passlen)
+
+ row=1
+ do col=1, passLen
+ Matrix (col,row) = SortedPassPhrase(col:col)
+ end do
+
+ ! Set rest ( row 2 ff.) of the Matrix: column by column
+ jj = 1
+ do col=1,passLen
+ row = 2
+ do while (argInString (jj:jj) .ne. ' ')
+ Matrix (col,row) = argInString (jj:jj)
+ jj = jj + 1
+ row = row + 1
+ enddo
+ jj = jj + 1
+ end do
+
+ if (VERBOSE) &
+ call printMatrix ('Decode: the reconstructed Code matrix is ', Matrix, nROw, passLen)
+
+ ! We know the columns of this matrix are sorted together with the password
+ !
+ ! restore the correct order of thet sorted matrix
+ call UndoSort (Matrix, passLen, nRow, argPassPhrase, passlen)
+
+ if (VERBOSE) &
+ call printMatrix ('Decode: After Undo Sorting, this becomes', Matrix, nRow, passLen)
+
+ ! The matrix is in the correct order now, so its rows, one by one, represent the first encoded string
+ !
+ jj = 1
+ tmpString = ' '
+ do row = 2, nRow ! Skip top row (=Passwprd)
+ do col=1,passLen
+ tmpString (jj:jj) = Matrix(col,row)
+ jj = jj + 1
+ end do
+ end do
+
+ ! Now we have the encoded string, each 2 letters are row/col in ADFGVX scheme
+ jj = 1
+ do ii=1, len_trim(tmpString), 2
+ row = index (ADFGVX, tmpString(ii:ii))
+ col = index (ADFGVX, tmpString((ii+1) : (ii+1)))
+ outString (jj:jj) = getChar (row,col,argAlphabet) ! Decode from row/col to clear text
+ jj = jj + 1
+ end do
+end subroutine decode
+
+! =============================================================================
+! Print all nRow x nCol elements of a Matrix, togehther with a descriptive text
+! =============================================================================
+subroutine printMatrix (comment, Matrix, nRow, nCol)
+ integer, intent(in) :: nRow, nCol
+ character (len=*), intent(in) :: Comment
+ character , intent(in) :: Matrix (nCol, nRow)
+ integer :: r, c
+
+ write (*,'(/A/)') Comment
+ do r=1, nROw
+ do c=1, nCol
+ write (*, '(A2)', advance='no') Matrix(c,r)
+ end do
+ write (*,*)
+ end do
+end subroutine printMatrix
+
+!=============================================================
+! Matrix has been sorted before, with top row as key elements.
+! Here undo that sort operation
+!=============================================================
+subroutine UndoSort (Matrix, nCol, nRow, argPassPhrase, passLen)
+ integer, intent(in) :: nCol, nRow, passLen
+ character, intent(inout) :: Matrix (nCol, nROw)
+ character :: resultMatrix (nCol, nROw)
+
+ character (len=passLen), intent(in) :: argPassPhrase
+
+ integer :: ii, jj, kk
+
+ do ii=1, passLen
+ ! find whatever letter should be at pos ii within the unscrambled string
+ jj = index (argPassPhrase, Matrix(ii, 1) )
+ ! so letter "PassPhrase(jj:jj)" should be at pos ii in line 1 of Matrix
+ if (jj .ne. ii) then
+ do kk=1, nRow
+ resultMatrix (jj,kk) = Matrix(ii,kk)
+ end do
+ else
+ do kk=1, nRow
+ resultMatrix (jj,kk) = Matrix(jj,kk)
+ end do
+ endif
+ end do
+ matrix = resultMatrix
+end subroutine UndoSort
+
+
+! ======================================================
+! Get Row and Column of a letter in the Polybius square
+! ======================================================
+subroutine getRC (c,row,col, argAlphabet)
+ character, intent(in) :: c
+ integer, intent(out) :: row,col
+ character (len=*), intent(in) :: argAlphabet ! Argument to use for encoding
+ integer :: idx
+
+ idx = index (argAlphabet, c) - 1
+
+ row = 1 + idx / ColWidth
+ col = 1 + mod (idx, ColWidth)
+
+end subroutine getRC
+
+! ==================================================
+! Return letter in row column of the Polybius square
+! ==================================================
+function getChar (row,column,argAlphabet) result (chr)
+ integer, intent(in) :: row, column
+ character (len=*), intent(in) :: argAlphabet ! Argument to use for encoding
+ character :: chr
+ integer :: idx
+
+ idx = (row-1) * ColWidth + column
+ chr = argAlphabet (idx:idx)
+
+end function getChar
+
+! ===========================================
+! Print original, encoded and decoded strings
+! ===========================================
+subroutine printResult (m1,m2,m3)
+ character (len=*), intent(in) :: m1,m2,m3
+ write (*,'("Original: ", A)') m1(:len_trim(m1))
+ write (*,'(" Encoded: ", A)') m2(:len_trim(m2))
+ write (*,'(" Decoded: ", A)') m3(:len_trim(m3))
+ print *
+end subroutine printResult
+
+! ================================================================================
+! Print the resulting Polybius square based on the alphabet used for encode/decode
+! ================================================================================
+subroutine PrintSquare (Comment, Alp, cw)
+ character (len=*), intent(in) :: Comment
+ character (len=*), intent(in) :: Alp
+ integer, intent(in) :: cw ! column width for dormatted display
+ integer:: ii, l
+
+ l = len_trim(alp)
+ write (*,'(/A/)') Comment
+ Write (*, "(' A D F G V X', /,' +------------',/ A, '|')", advance='no') ADFGVX (1:1)
+ do ii=1, l
+ write (*, '(A2)', advance='no') Alp(ii:ii)
+ if (mod (ii, cw) .eq. 0) then
+ if (ii .ne. l) then
+ write (*,'(/,A1,"|")', advance='no') ADFGVX (1 + ii/cw:1 + ii/cw)
+ else
+ write (*,*) ! just EOL
+ endif
+ endif
+ end do
+ print * ! one extra blank line
+end subroutine PrintSquare
+
+
+end program ADFGVXCipher
diff --git a/Task/ADFGVX-cipher/Free-Pascal-Lazarus/adfgvx-cipher.pas b/Task/ADFGVX-cipher/Free-Pascal-Lazarus/adfgvx-cipher.pas
new file mode 100644
index 0000000000..b35f201644
--- /dev/null
+++ b/Task/ADFGVX-cipher/Free-Pascal-Lazarus/adfgvx-cipher.pas
@@ -0,0 +1,198 @@
+program adfgvxcipher;
+
+uses
+ SysUtils,
+ Classes;
+
+const
+ ADFGVX = 'ADFGVX';
+ ALPHABET = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789';
+ MESSAGE = 'ATTACKAT1200AM';
+
+type
+ //tPolybiusarr = array[1..6,1..6] of string;
+ tPolybiusarr = array[1..6, 1..6] of char;
+
+ procedure init_Polybius(var Polybius: tPolybiusarr);
+
+ procedure ShuffleString(var S: string);
+ var
+ i, j: integer;
+ c: char;
+ begin
+ for i := Length(S) downto 2 do
+ begin
+ j := Random(i) + 1; // 1..i
+ c := S[i];
+ S[i] := S[j];
+ S[j] := c;
+ end;
+ end;
+
+ var
+ ShuffledAlphabet: string;
+ x, y, i: integer;
+ begin
+ ShuffledAlphabet := ALPHABET;
+ ShuffleString(ShuffledAlphabet);
+ i := 1;
+ for x := 1 to 6 do
+ for y := 1 to 6 do
+ begin
+ Polybius[x, y] := ShuffledAlphabet[i];
+ Inc(i);
+ end;
+ end;
+
+ procedure PrintPolybius(Polybius: tPolybiusarr);
+ var
+ x, y: integer;
+ ch: char;
+ begin
+ writeln('The 6 x 6 Polybius square:');
+ writeln;
+ Write(' |');
+ for ch in ADFGVX do
+ Write(ch: 2);
+ writeln;
+ writeln('---------------');
+ for x := 1 to 6 do
+ begin
+ Write(ADFGVX[x], ' |');
+ for y := 1 to 6 do
+ begin
+ Write(Polybius[x, y]: 2);
+ end;
+ writeln;
+ end;
+ end;
+
+ function CreateKey(size: integer): string;
+
+ procedure FilterList(var lst: TStringList; size: integer);
+
+ function HasRepeatedCharacters(const str: string): boolean;
+ var
+ seen: array[0..255] of boolean;
+ i: integer;
+ c: byte;
+ begin
+ FillChar(seen, SizeOf(seen), False);
+ for i := 1 to Length(str) do
+ begin
+ c := Ord(str[i]);
+ if seen[c] then
+ Exit(True); // repeated character found
+ seen[c] := True;
+ end;
+ Result := False; // no repeats
+ end;
+
+ var
+ x: integer;
+ begin
+ for x := lst.Count - 1 downto 0 do
+ if (length(lst[x]) <> size) or HasRepeatedCharacters(lst[x]) then lst.Delete(x);
+ end;
+
+ const
+ FNAME = 'unixdict.txt';
+ var
+ list: TStringList;
+ begin
+ if (size < 7) or (size > 12) then
+ begin
+ writeln('Key should contain between 7 and 12 letters, both inclusive.');
+ halt;
+ end;
+ list := TStringList.Create;
+ list.LoadFromFile(FNAME);
+ filterlist(list, size);
+ Result := UpperCase(list[random(list.Count)]);
+ list.Free;
+ end;
+
+ function FindCharachter(ch: char; polybius: tPolybiusarr): string;
+ var
+ x, y: integer;
+ begin
+ for x := 1 to 6 do
+ for y := 1 to 6 do
+ if polybius[x, y] = ch then
+ exit(ADFGVX[x] + ADFGVX[y]);
+ end;
+
+ function Encrypt(plainText, key: string; Polybius: tPolybiusarr): string;
+ var
+ ch: char;
+ str: string;
+ lst: TStringList;
+ x, keylength: integer;
+ begin
+ str := '';
+ keylength := length(key);
+ lst := TStringList.Create;
+ for x := 1 to keylength do
+ lst.Add(key[x]);
+ x := 0;
+ for ch in plainText do
+ begin
+ lst[x] := lst[x] + FindCharachter(ch, Polybius);
+ Inc(x);
+ if x = keylength then x := 0;
+ end;
+ lst.Sort;
+ writeln;
+ for x := 0 to keylength - 1 do
+ str := str + lst[x] + ' ';
+ Result := TrimRight(str);
+ lst.Free;
+ end;
+
+ function Decrypt(encryptedTex, key: string; polybius: tPolybiusarr): string;
+ // Note: simplified decryption logic for demonstration purposes
+ // need some work for longer messages
+ var
+ lst, tmp: TStringList;
+ ch: char;
+ s, str: string;
+ begin
+ lst := TStringList.Create;
+ tmp := TStringList.Create;
+ lst.AddDelimitedtext(encryptedTex, ' ', True);
+ for ch in key do
+ for str in lst do
+ if str[1] = ch then
+ begin
+ tmp.Add(str);
+ break;
+ end;
+ Result := '';
+ s := '';
+ for str in tmp do
+ begin
+ Result := Result + polybius[pos(str[2], ADFGVX), pos(str[3], ADFGVX)];
+ if length(str) > 3 then s := s + polybius[pos(str[4], ADFGVX), pos(str[5], ADFGVX)];
+ end;
+ Result := Result + s;
+ lst.Free;
+ tmp.Free;
+ end;
+
+var
+ Polybius: tPolybiusarr;
+ key, encryptedMessage, decryptedMessage: string;
+
+begin
+ Randomize;
+ init_Polybius(Polybius);
+ PrintPolybius(Polybius);
+ key := createkey(Random(12 - 7 + 1) + 7); //set length of word to 7 - 12
+ encryptedMessage := Encrypt(MESSAGE, key, Polybius);
+ decryptedMessage := Decrypt(encryptedMessage, key, polybius);
+ writeln('The key is : ', key);
+ writeln('the plain message is : ', MESSAGE);
+ writeln('the encrypted message is: ', encryptedMessage);
+ writeln('the decrypted message is: ', decryptedMessage);
+
+end.
diff --git a/Task/ADFGVX-cipher/Mathematica/adfgvx-cipher.math b/Task/ADFGVX-cipher/Mathematica/adfgvx-cipher.math
new file mode 100644
index 0000000000..b66c4cb9fc
--- /dev/null
+++ b/Task/ADFGVX-cipher/Mathematica/adfgvx-cipher.math
@@ -0,0 +1,24 @@
+encrypt[plaintext_, polybius_, key_] := Module[{fraction, fractioned},
+ fraction = Thread[Characters[polybius] -> Tuples[Characters["ADFGVX"], 2]];
+ fractioned = Partition[Flatten[Characters[plaintext] /. fraction], UpTo[StringLength[key]]];
+ StringJoin[Flatten[Part[Flatten[fractioned, {2}], Ordering[Characters[key]]]]]];
+
+decrypt[encrypted_, polybius_, key_] := Module[{perm, colLengths, fractioned, defraction},
+ perm = Ordering[Characters[key]];
+ colLengths = Length /@ Part[Flatten[Partition[Characters[encrypted], UpTo[Length[perm]]], {2}], perm];
+ fractioned = Flatten[Part[TakeList[Characters[encrypted], colLengths], InversePermutation[perm]], {2}];
+ defraction = Thread[Tuples[Characters["ADFGVX"], 2] -> Characters[polybius]];
+ StringJoin[Partition[Flatten[fractioned], 2] /. defraction]];
+
+words = ReadList["unixdict.txt", Word];
+key = Select[words, StringLength[#] == 9 && DuplicateFreeQ[Characters[#]] &] // RandomChoice;
+polybius = StringJoin@RandomSample@Characters["ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"];
+plaintext = "ATTACKAT1200AM";
+encrypted = encrypt[plaintext, polybius, key];
+decrypted = decrypt[encrypted, polybius, key];
+
+Print["Key: ", key];
+Print["Polybius: ", polybius];
+Print["Plaintext: ", plaintext];
+Print["Encrypted: ", encrypted];
+Print["Decrypted: ", decrypted];
diff --git a/Task/ADFGVX-cipher/R/adfgvx-cipher.r b/Task/ADFGVX-cipher/R/adfgvx-cipher.r
new file mode 100644
index 0000000000..87fc86e172
--- /dev/null
+++ b/Task/ADFGVX-cipher/R/adfgvx-cipher.r
@@ -0,0 +1,173 @@
+# The ADFGVX cipher.
+# See also eg. https://www.nku.edu/~christensen/092hnr304%20ADFGVX.pdf
+
+# ADFGVX class using R6
+library(R6)
+
+ADFGVX <- R6Class("ADFGVX",
+ public = list(
+ polybius = NULL,
+ pdim = NULL,
+ key = NULL,
+ keylen = NULL,
+ alphabet = NULL,
+ encode = NULL,
+ decode = NULL,
+
+ # Constructor
+ initialize = function(s, k, alph = "ADFGVX") {
+ self$polybius <- toupper(strsplit(s, "")[[1]])
+ self$pdim <- floor(sqrt(length(self$polybius)))
+ self$alphabet <- toupper(strsplit(alph, "")[[1]])
+
+ # Create encoding dictionary
+ self$encode <- list()
+ for (i in 1:self$pdim) {
+ for (j in 1:self$pdim) {
+ char <- self$polybius[(i - 1) * self$pdim + j]
+ self$encode[[char]] <- c(self$alphabet[i], self$alphabet[j])
+ }
+ }
+
+ # Create decoding dictionary
+ self$decode <- list()
+ for (char in names(self$encode)) {
+ key_str <- paste(self$encode[[char]], collapse = "")
+ self$decode[[key_str]] <- char
+ }
+
+ stopifnot(self$pdim^2 == length(self$polybius) &&
+ self$pdim == length(self$alphabet))
+
+ self$key <- toupper(strsplit(k, "")[[1]])
+ self$keylen <- length(self$key)
+ },
+
+ # Encrypt with the ADFGVX cipher
+ encrypt = function(s) {
+ chars_upper <- toupper(strsplit(s, "")[[1]])
+ chars_filtered <- chars_upper[chars_upper %in% self$polybius]
+
+ # Encode characters
+ chars <- unlist(lapply(chars_filtered, function(c) self$encode[[c]]))
+
+ # Create column vectors
+ colvecs <- list()
+ for (i in 1:self$keylen) {
+ indices <- seq(i, length(chars), by = self$keylen)
+ colvecs[[self$key[i]]] <- chars[indices]
+ }
+
+ # Sort by key
+ sorted_names <- sort(names(colvecs))
+ result <- unlist(lapply(sorted_names, function(name) colvecs[[name]]))
+
+ return(paste(result, collapse = ""))
+ },
+
+ # Decrypt with the ADFGVX cipher
+ decrypt = function(s) {
+ chars <- toupper(strsplit(s, "")[[1]])
+ chars <- chars[chars %in% self$alphabet]
+
+ sortedkey <- sort(self$key)
+ order <- sapply(sortedkey, function(ch) which(self$key == ch)[1])
+ originalorder <- sapply(self$key, function(ch) which(sortedkey == ch)[1])
+
+ # Calculate strides (column lengths)
+ div_result <- length(chars) %/% self$keylen
+ rem_result <- length(chars) %% self$keylen
+ strides <- sapply(order, function(i) {
+ div_result + ifelse(rem_result >= i, 1, 0)
+ })
+
+ # Calculate starts and ends of columns
+ starts <- c(1, cumsum(strides[-length(strides)]) + 1)
+ ends <- starts + strides - 1
+
+ # Get reordered columns
+ cols <- lapply(originalorder, function(i) {
+ chars[starts[i]:ends[i]]
+ })
+
+ # Recover the rows
+ nrows <- (length(chars) - 1) %/% self$keylen + 1
+ pairs <- c()
+ for (i in 1:nrows) {
+ for (j in 1:self$keylen) {
+ if ((i - 1) * self$keylen + j > length(chars)) break
+ pairs <- c(pairs, cols[[j]][i])
+ }
+ }
+
+ # Decode pairs
+ result <- c()
+ for (i in seq(1, length(pairs) - 1, by = 2)) {
+ pair_str <- paste(pairs[i:(i+1)], collapse = "")
+ result <- c(result, self$decode[[pair_str]])
+ }
+
+ return(paste(result, collapse = ""))
+ }
+ )
+)
+
+# Main execution
+set.seed(123) # For reproducibility
+POLYBIUS <- paste(sample(strsplit("ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789", "")[[1]]),
+ collapse = "")
+
+# Get dictionary words - try multiple sources
+get_valid_key <- function() {
+ # Try to read unixdict.txt if it exists
+ if (file.exists("unixdict.txt")) {
+ dict_words <- readLines("unixdict.txt")
+ } else {
+ # Use sample words if file doesn't exist
+ dict_words <- c("absolutes", "abruption", "abundance", "abysmally",
+ "acrobatic", "algorithm", "ambiguity", "amplitude",
+ "ancestory", "archetype", "asynchron", "auctioned",
+ "backbone", "backfired", "backlights", "bandwidth",
+ "benchmark", "biography", "birthplace", "blasphemy",
+ "boulevard", "bricklaying", "broadcast", "butchering",
+ "cauterize", "chemicals", "chromatic", "clipboard",
+ "completing", "conjugate", "copyright", "daughters",
+ "debuggers", "delimiters", "demograph", "dialyzing",
+ "dictionary", "education", "equations", "factorize",
+ "geography", "goshdarn", "graciously", "graphed",
+ "hampshire", "imploding", "indexable", "jeculates",
+ "keyboards", "labyrinth", "livestock", "logarithm",
+ "machinery", "molecules", "nightmare", "obscurity",
+ "particles", "quizboard", "racehorst", "reduction",
+ "savepoint", "sectional", "shipyard", "splatting",
+ "substance", "technology", "ulceration", "vineyard",
+ "warehouse", "workplace", "xanthopsy", "yachtsmen")
+ }
+
+ # Filter for 9-letter words with unique characters
+ valid_words <- dict_words[sapply(dict_words, function(w) {
+ n <- nchar(w)
+ n == 9 && length(unique(strsplit(w, "")[[1]])) == n
+ })]
+
+ if (length(valid_words) == 0) {
+ stop("No valid 9-letter words with unique characters found")
+ }
+
+ return(toupper(sample(valid_words, 1)))
+}
+
+KEY <- get_valid_key()
+
+# Create cipher and encrypt/decrypt
+SECRETS <- ADFGVX$new(POLYBIUS, KEY)
+message <- "ATTACKAT1200AM"
+
+cat("Polybius:", POLYBIUS, ", Key:", KEY, "\n")
+cat("Message:", message, "\n")
+
+encoded <- SECRETS$encrypt(message)
+decoded <- SECRETS$decrypt(encoded)
+
+cat("Encoded:", encoded, "\n")
+cat("Decoded:", decoded, "\n")
diff --git a/Task/AKS-test-for-primes/Ada/aks-test-for-primes.adb b/Task/AKS-test-for-primes/Ada/aks-test-for-primes.adb
new file mode 100644
index 0000000000..0ea9ed95f6
--- /dev/null
+++ b/Task/AKS-test-for-primes/Ada/aks-test-for-primes.adb
@@ -0,0 +1,88 @@
+with Ada.Text_IO;
+
+procedure Test_For_Primes is
+
+ type Pascal_Triangle_Type is array (Natural range <>) of Long_Long_Integer;
+
+ function Calculate_Pascal_Triangle (N : in Natural) return Pascal_Triangle_Type is
+ Pascal_Triangle : Pascal_Triangle_Type (0 .. N);
+ begin
+ Pascal_Triangle (0) := 1;
+ for I in Pascal_Triangle'First .. Pascal_Triangle'Last - 1 loop
+ Pascal_Triangle (1 + I) := 1;
+ for J in reverse 1 .. I loop
+ Pascal_Triangle (J) := Pascal_Triangle (J - 1) - Pascal_Triangle (J);
+ end loop;
+ Pascal_Triangle (0) := -Pascal_Triangle (0);
+ end loop;
+ return Pascal_Triangle;
+ end Calculate_Pascal_Triangle;
+
+ function Is_Prime (N : Integer) return Boolean is
+ I : Integer;
+ Result : Boolean := True;
+ Pascal_Triangle : constant Pascal_Triangle_Type := Calculate_Pascal_Triangle (N);
+ begin
+ I := N / 2;
+ while Result and I > 1 loop
+ Result := Result and Pascal_Triangle (I) mod Long_Long_Integer (N) = 0;
+ I := I - 1;
+ end loop;
+ return Result;
+ end Is_Prime;
+
+ function Image (N : in Long_Long_Integer;
+ Sign : in Boolean := False) return String is
+ Image : constant String := N'Image;
+ begin
+ if N < 0 then
+ return Image;
+ else
+ if Sign then
+ return "+" & Image (Image'First + 1 .. Image'Last);
+ else
+ return Image (Image'First + 1 .. Image'Last);
+ end if;
+ end if;
+ end Image;
+
+ procedure Show (Triangle : in Pascal_Triangle_Type) is
+ use Ada.Text_IO;
+ Begin
+ for I in reverse Triangle'Range loop
+ Put (Image (Triangle (I), Sign => True));
+ Put ("x^");
+ Put (Image (Long_Long_Integer (I)));
+ Put (" ");
+ end loop;
+ end Show;
+
+ procedure Show_Pascal_Triangles is
+ use Ada.Text_IO;
+ begin
+ for N in 0 .. 9 loop
+ declare
+ Pascal_Triangle : constant Pascal_Triangle_Type := Calculate_Pascal_Triangle (N);
+ begin
+ Put ("(x-1)^" & Image (Long_Long_Integer (N)) & " = ");
+ Show (Pascal_Triangle);
+ New_Line;
+ end;
+ end loop;
+ end Show_Pascal_Triangles;
+
+ procedure Show_Primes is
+ use Ada.Text_IO;
+ begin
+ for N in 2 .. 63 loop
+ if Is_Prime (N) then
+ Put (N'Image);
+ end if;
+ end loop;
+ New_Line;
+ end Show_Primes;
+
+begin
+ Show_Pascal_Triangles;
+ Show_Primes;
+end Test_For_Primes;
diff --git a/Task/AKS-test-for-primes/EasyLang/aks-test-for-primes.easy b/Task/AKS-test-for-primes/EasyLang/aks-test-for-primes.easy
index 54fc26429d..10fa6635e4 100644
--- a/Task/AKS-test-for-primes/EasyLang/aks-test-for-primes.easy
+++ b/Task/AKS-test-for-primes/EasyLang/aks-test-for-primes.easy
@@ -1,7 +1,7 @@
func[] coefs n .
- list[] = [ 1 ]
- arrbase list[] 0
- for k = 0 to n : list[] &= list[k] * (n - k) / (k + 1)
+ len list[] n + 2
+ list[0] = 1
+ for k = 0 to n : list[k + 1] = list[k] * (n - k) / (k + 1)
for k = 1 step 2 to n : list[k] = -list[k]
return list[]
.
diff --git a/Task/AKS-test-for-primes/Loglan82/aks-test-for-primes.loglan82 b/Task/AKS-test-for-primes/Loglan82/aks-test-for-primes.loglan82
new file mode 100644
index 0000000000..73629f52ea
--- /dev/null
+++ b/Task/AKS-test-for-primes/Loglan82/aks-test-for-primes.loglan82
@@ -0,0 +1,89 @@
+program AKS;
+(* AKS test for primes *)
+
+const
+ Pas_tri_last = 33; (* 33 for 32-bit integer type; 17 for 16-bit integer *)
+var
+ n: integer;
+
+ (* Calculate the n'th line 0 .. middle *)
+ unit Pascal_triangle: procedure (n: integer; Pas_tri: arrayof integer);
+ var
+ j, k: integer;
+ begin
+ Pas_tri(0) := 1;
+ j := 1;
+ while j <= n
+ do
+ j := j + 1;
+ k := j div 2;
+ Pas_tri(k) := Pas_tri(k - 1);
+ while k >= 1
+ do
+ Pas_tri(k) := Pas_tri(k) + Pas_tri(k - 1);
+ k := k - 1
+ od;
+ od;
+ end Pascal_triangle;
+
+ unit is_prime: function (n: integer): boolean;
+ var
+ i: integer,
+ Pas_tri: arrayof integer;
+ begin
+ array Pas_tri dim (0 : n);
+ call Pascal_triangle(n, Pas_tri);
+ result := true;
+ i := n div 2;
+ while result and (i > 1)
+ do
+ result := result and (Pas_tri(i) mod n = 0);
+ i := i - 1;
+ od;
+ end is_prime;
+
+ unit vz: function (b: boolean): character;
+ begin
+ if b then result := '-' else result := '+' fi;
+ end vz;
+
+ unit expand_poly: procedure (n: integer);
+ var
+ Pas_tri: arrayof integer,
+ bvz: boolean,
+ j: integer;
+ begin
+ array Pas_tri dim (0 : n);
+ case n
+ when 0: writeln("(x - 1) ^ 0 = 1")
+ when 1: writeln("(x - 1) ^ 1 = x - 1")
+ otherwise
+ call Pascal_triangle(n, Pas_tri);
+ write("(x - 1) ^ ", n: 1, " = x ^ ", n: 1, " ");
+ bvz := true;
+ for j := n - 1 downto (n div 2) + 1
+ do
+ write(vz(bvz), " ", Pas_tri(n - j): 1, " * x ^ ", j: 1, " ");
+ bvz := not bvz;
+ od;
+ for j := (n div 2) downto 2
+ do
+ write(vz(bvz), " ", Pas_tri(j): 1, " * x ^ ", j: 1, " ");
+ bvz := not bvz
+ od;
+ write(vz(bvz), " ", Pas_tri(1): 1, " * x ");
+ bvz := not bvz;
+ writeln(vz(bvz), " ", Pas_tri(0): 1);
+ esac;
+ end expand_poly;
+
+begin
+ for n := 0 to 9
+ do
+ call expand_poly(n)
+ od;
+ for n := 2 to Pas_tri_last do
+ if is_prime(n) then write(n: 1, " ") fi;
+ od;
+ writeln;
+end
diff --git a/Task/AKS-test-for-primes/PowerShell/aks-test-for-primes.ps1 b/Task/AKS-test-for-primes/PowerShell/aks-test-for-primes.ps1
new file mode 100644
index 0000000000..c79bcdf5e7
--- /dev/null
+++ b/Task/AKS-test-for-primes/PowerShell/aks-test-for-primes.ps1
@@ -0,0 +1,84 @@
+# AKS test for primes
+
+$script:PasTriMax = 61 # for long type of Pascal triangle numbers
+
+function Pascal-Triangle {
+ # Calculate the n'th line 0.. middle
+ param(
+ [int]$N
+ )
+
+ $pasTri = [long[]]::new([math]::Ceiling(($N + 2) / 2))
+ $pasTri[0] = 1
+ [int]$j = 1
+ while ($j -le $N) {
+ $j++
+ [int]$k = [math]::Floor($j / 2)
+ $pasTri[$k] = $pasTri[$k - 1]
+ for (; $k -ge 1; $k--) {
+ $pasTri[$k] += $pasTri[$k - 1]
+ }
+ }
+ # Now: $j -eq ($N + 1), so $k -eq [math]::Floor(($N + 1) / 2)
+ return $pasTri
+}
+
+function Expand-Poly {
+ param ([int]$N)
+
+ if ($N -gt $script:PasTriMax) {
+ throw "$N is out of range"
+ }
+ switch($N) {
+ 0 {Write-Output "(x-1)^0 = 1"}
+ 1 {Write-Output "(x-1)^1 = x-1"}
+ default {
+ $VZ = @('+', '-')
+ $pasTri = Pascal-Triangle($N)
+ [string]$outTri = @()
+ $outTri += "(x-1)^$N = x^$N"
+ [bool]$bVz = $true
+ [int]$nDiv2 = [math]::Floor($N / 2)
+ for ([int]$j = $N - 1; $j -gt $nDiv2; $j--) {
+ $outTri += "$($VZ[$bVz]) $($pasTri[$N - $j])*x^$j"
+ $bVz = -not $bVz
+ }
+ for ([int]$j = $nDiv2; $j -gt 1; $j--) {
+ $outTri += "$($VZ[$bVz]) $($pasTri[$j])*x^$j"
+ $bVz = -not $bVz
+ }
+ $outTri += "$($VZ[$bVz]) $($pasTri[1])*x"
+ $bVz = -not $bVz
+ $outTri += "$($VZ[$bVz]) $($pasTri[0])"
+ Write-Output $outTri
+ }
+ }
+}
+
+function Is-Prime {
+ param([int]$N)
+
+ if ($N -gt $script:PasTriMax) {
+ throw "$N is out of range"
+ }
+ $pasTri = Pascal-Triangle($N)
+ [bool]$res = $true
+ [int]$i = [math]::Floor($N / 2)
+ while ($res -and ($i -gt 1)) {
+ $res = $res -and ($pasTri[$i] % $N -eq 0)
+ $i--
+ }
+ return $res
+}
+
+# Test program
+foreach ($n in 0..9) {
+ Expand-Poly($n)
+}
+[string]$primes = @()
+foreach ($n in 2..$script:PasTriMax) {
+ if (Is-Prime($n)) {
+ $primes += "{0,3}" -f $n
+ }
+}
+Write-Output $primes
diff --git a/Task/AKS-test-for-primes/QuickBASIC/aks-test-for-primes.basic b/Task/AKS-test-for-primes/QuickBASIC/aks-test-for-primes.basic
new file mode 100644
index 0000000000..87b3cb1b3b
--- /dev/null
+++ b/Task/AKS-test-for-primes/QuickBASIC/aks-test-for-primes.basic
@@ -0,0 +1,76 @@
+' AKS test for primes
+DECLARE SUB PascalTriangle (N%, PasTri&())
+DECLARE FUNCTION IsPrime% (N%)
+DECLARE SUB ExpandPoly (N%)
+CONST PASTRILAST% = 33 ' for 32-bit integer type
+CONST TRUE% = -1, FALSE% = 0
+FOR N% = 0 TO 9
+ CALL ExpandPoly(N%)
+NEXT N%
+FOR N% = 2 TO PASTRILAST%
+ IF IsPrime%(N%) THEN PRINT USING "###"; N%;
+NEXT N%
+PRINT
+END
+
+SUB ExpandPoly (N%)
+ DIM VZ$(0 TO 1)
+ VZ$(0) = "+"
+ VZ$(1) = "-"
+ DIM PasTri&(0 TO PASTRILAST%)
+ IF N% > PASTRILAST% THEN
+ PRINT N%; "is out of range"
+ STOP
+ END IF
+ SELECT CASE N%
+ CASE 0
+ PRINT "(x - 1) ^ 0 = 1"
+ CASE 1
+ PRINT "(x - 1) ^ 1 = x - 1"
+ CASE ELSE
+ CALL PascalTriangle(N%, PasTri&())
+ PRINT "(x - 1) ^"; N%; " = x ^"; N%;
+ BVZ% = 1
+ FOR J% = N% - 1 TO N% \ 2 + 1 STEP -1
+ PRINT VZ$(BVZ%); PasTri&(N% - J%); "* x ^"; J%;
+ BVZ% = ABS(1 - BVZ%)
+ NEXT J%
+ FOR J% = N% \ 2 TO 2 STEP -1
+ PRINT VZ$(BVZ%); PasTri&(J%); "* x ^"; J%;
+ BVZ% = ABS(1 - BVZ%)
+ NEXT J%
+ PRINT VZ$(BVZ%); PasTri&(1); "* x ";
+ BVZ% = ABS(1 - BVZ%)
+ PRINT VZ$(BVZ%); PasTri&(0)
+ END SELECT
+END SUB
+
+FUNCTION IsPrime% (N%)
+ DIM PasTri&(0 TO PASTRILAST%)
+ IF N% > PASTRILAST% THEN
+ PRINT N%; "is out of range"
+ STOP
+ END IF
+ CALL PascalTriangle(N%, PasTri&())
+ Res% = TRUE%
+ I% = N% \ 2
+ DO WHILE Res% AND (I% > 1)
+ Res% = Res% AND (PasTri&(I%) MOD N% = 0)
+ I% = I% - 1
+ LOOP
+ IsPrime% = Res%
+END FUNCTION
+
+SUB PascalTriangle (N%, PasTri&())
+ ' Calculate the N'th line 0.. middle
+ PasTri&(0) = 1
+ J% = 1
+ DO WHILE J% <= N%
+ J% = J% + 1
+ K% = J% \ 2
+ PasTri&(K%) = PasTri&(K% - 1)
+ FOR K% = K% TO 1 STEP -1
+ PasTri&(K%) = PasTri&(K%) + PasTri&(K% - 1)
+ NEXT K%
+ LOOP
+END SUB
diff --git a/Task/AKS-test-for-primes/REXX/aks-test-for-primes-2.rexx b/Task/AKS-test-for-primes/REXX/aks-test-for-primes-2.rexx
index c900672143..2cc1ad89b3 100644
--- a/Task/AKS-test-for-primes/REXX/aks-test-for-primes-2.rexx
+++ b/Task/AKS-test-for-primes/REXX/aks-test-for-primes-2.rexx
@@ -1,87 +1,63 @@
--- 23 Aug 2025
+-- 21 Feb 2026
include Setting
arg p
-if p = '' then
- p = 10
+if p='' then
+ p=100
-say 'AKS TEST FOR PRIMES'
+say 'AKS TEST FOR PRIMES' p
say version
say
-numeric digits Max(10,Abs(p)%3)
-call Combis p
-call Polynomials p
-call Showprimes p
+numeric digits Max(10,Abs(p%3))
+say Combmemo(p) 'combinations generated'
+say
+say Getprimes(p) 'primes found'
+say
+call Showprimes
+say
+call Timer
exit
-Combis:
-procedure expose comb.
+Getprimes:
+procedure expose Poly. Work. Prim. Memo.
arg p
-call Time('r')
-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
-
-Polynomials:
-procedure expose poly. comb. work. prim.
-arg p
-call Time('r')
-say 'Polynomials...'
-if p < 0 then
- b = Abs(p)
-else
- b = 0
-p = Abs(p); prim. = 0; n = 0
-do i = b to p
- a = PowP('1 -1',i)
- if i < 11 then
- say '(x-1)^'i '=' Lst2FormP(Arr2LstP())
- s = 1
- do j = 2 to poly.0-1
- a = poly.coef.j
- if a//i > 0 then do
- s = 0
+q=-p*(p<0); p=Abs(p)
+say 'Get primes...'
+Poly.=0; Prim.=0; n=0
+do i=q to p
+-- Generate power of x-1, also saves coefficients
+ a=PowP('1 -1',i)
+ if i<11 then
+ say '(x-1)^'i '=' Poly2form(Stem2poly())
+-- AKS algorithm using saved coefficients
+ s=1
+ do j=2 to Poly.0-1
+ a=Poly.j
+ if a//i>0 then do
+ s=0
leave j
end
end
- if s = 1 then do
- if i > 1 then do
- n = n+1
- prim.n = i
+-- Bump prime
+ if s=1 then do
+ if i>1 then do
+ n+=1; Prim.n=i
end
end
end
-prim.0 = n
-say Format(Time('e'),,3) 'seconds'
-say
-return
+-- Prime count
+Prim.0=n
+return n
Showprimes:
-procedure expose prim.
-arg p
-call Time('r')
+procedure expose Prim.
say 'Primes...'
-if p < 0 then do
- p = Abs(p)
- if prim.0 > 0 then
- say p 'is prime'
- else
- say p 'is not prime'
+do i=1 to Prim.0
+ call Charout ,Right(Prim.i,5)
+ if i//20=0 then
+ say
end
-else do
- do i = 1 to prim.0
- call Charout ,Right(prim.i,5)
- if i//20 = 0 then
- say
- end
- say
-end
-say Format(Time('e'),,3) 'seconds'
say
return
+-- Combmemo; PowP; Poly2form; Stem2poly; Timer
include Math
diff --git a/Task/ASCII-art-diagram-converter/Crystal/ascii-art-diagram-converter-1.cr b/Task/ASCII-art-diagram-converter/Crystal/ascii-art-diagram-converter-1.cr
new file mode 100644
index 0000000000..8116d0c048
--- /dev/null
+++ b/Task/ASCII-art-diagram-converter/Crystal/ascii-art-diagram-converter-1.cr
@@ -0,0 +1,124 @@
+macro convert_diagram (typename, s)
+ {% lines = s.strip.split(/\r?\n/).map(&.strip) %}
+
+ # check if it's actually a diagram
+ {% for line, i in lines %}
+ {% unless (i % 2 == 0 && line =~ /^\+(--\+)+$/) || # well formed border?
+ (i % 2 != 0 && line =~ /^\|([ \w]+\|)+$/) %} # inside probably ok?
+ {% raise "bad diagram format" %}
+ {% end %}
+ {% end %}
+
+ # count size
+ {% row_size = lines[0].split('+').size - 2 %}
+ {% unless [8, 16, 32, 64, 128].includes?(row_size) %}
+ {% raise "Invalid data size : " + row_size %}
+ {% end %}
+
+ # get rid of the borders now
+ {% lines = lines.reject {|line| line.starts_with?("+--+") } %}
+
+ {% element_type = "UInt" + row_size.stringify %}
+ {% suffix = "_u" + row_size.stringify %}
+ {% array_size = lines.size %}
+ {% field_names = [] of StringLiteral %}
+ {% field_sizes = [] of IntLiteral %}
+
+ # build the type
+ class {{typename.id}}
+ @data = Array({{element_type.id}}).new({{array_size.id}}, 0)
+
+ def self.from_io (io)
+ o = new
+ o.@data.map! { {{element_type.id}}.from_io(io, IO::ByteFormat::NetworkEndian) }
+ o
+ end
+
+ def to_io (io)
+ @data.each do |n| n.to_io(io, IO::ByteFormat::NetworkEndian) end
+ end
+
+ {% for line, idx in lines %}
+ {% fields = line.split('|')[1...-1] %}
+ {% offset = row_size %}
+ {% for field in fields %}
+ {% field_size = (field.size+1) // 3 %}
+ {% field_sizes << field_size %}
+ {% field_name = field.strip.downcase %}
+ {% field_names << field_name %}
+ {% offset -= field_size %}
+
+ {% if field_size == row_size %}
+ def {{field_name.id}}
+ @data[{{idx.id}}]
+ end
+
+ def {{field_name.id}}= (v)
+ @data[{{idx.id}}] = v.to{{suffix.id}}
+ end
+ {% else %}
+ def {{field_name.id}}
+ @data[{{idx.id}}].bits({{offset.id}} ... {{(offset + field_size).id}})
+ end
+
+ def {{field_name.id}}= (v)
+ mask = (1{{suffix.id}} << {{field_size.id}}) - 1
+ raise "overflow" unless 0 <= v <= mask
+ @data[{{idx.id}}] = (@data[{{idx.id}}] & ~(mask << {{offset.id}})) | (v.to{{suffix.id}} << {{offset.id}})
+ end
+ {% if field_size == 1 %}
+ def {{field_name.id}}= (v : Bool)
+ self.{{field_name.id}} = v ? 1 : 0
+ end
+
+ def {{field_name.id}}?
+ self.{{field_name.id}} == 1
+ end
+ {% end %}
+ {% end %}
+ {% end %}
+ {% end %}
+ def values
+ {
+ {% for field_name in field_names %}
+ {{ field_name.id }}: self.{{field_name.id}},
+ {% end %}
+ }
+ end
+ def self.field_sizes
+ {
+ {% for field_name, i in field_names %}
+ {{ field_name.id }}: {{ field_sizes[i].id }},
+ {% end %}
+ }
+ end
+ end # class
+end
+
+convert_diagram MessageHeader, <<-EOD
+ +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+ | ID |
+ +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+ |QR| Opcode |AA|TC|RD|RA| Z | RCODE |
+ +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+ | QDCOUNT |
+ +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+ | ANCOUNT |
+ +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+ | NSCOUNT |
+ +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+ | ARCOUNT |
+ +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+ EOD
+
+io = IO::Memory.new "78477bbf5496e12e1bf169a4".hexbytes
+
+h = MessageHeader.from_io(io)
+
+sizes = MessageHeader.field_sizes
+
+puts " Field Sz Value (binary)"
+puts " ------------------------------"
+h.values.each do |name, value|
+ puts "%8s: %2d %5d %0*b" % {name, sizes[name], value, sizes[name], value}
+end
diff --git a/Task/ASCII-art-diagram-converter/Crystal/ascii-art-diagram-converter-2.cr b/Task/ASCII-art-diagram-converter/Crystal/ascii-art-diagram-converter-2.cr
new file mode 100644
index 0000000000..1b1cd2f7a1
--- /dev/null
+++ b/Task/ASCII-art-diagram-converter/Crystal/ascii-art-diagram-converter-2.cr
@@ -0,0 +1,231 @@
+ class MessageHeader
+ @data = Array(UInt16).new(6, 0)
+
+ def self.from_io(io)
+ o = new
+ (o.@data).map! do UInt16.from_io(io, IO::ByteFormat::NetworkEndian) end
+ o
+ end
+
+ def to_io(io)
+ @data.each do |n| n.to_io(io, IO::ByteFormat::NetworkEndian) end
+ end
+
+ def id
+ @data[0]
+ end
+
+ def id=(v)
+ @data[0] = v.to_u16
+ end
+
+ def qr
+ @data[1].bits(15...16)
+ end
+
+ def qr=(v)
+ mask = (1_u16 << 1) - 1
+ if 0 <= v && v <= mask
+ else
+ raise("overflow")
+ end
+ @data[1] = (@data[1] & (~(mask << 15))) | (v.to_u16 << 15)
+ end
+
+ def qr=(v : Bool)
+ self.qr = v ? 1 : 0
+ end
+
+ def qr?
+ self.qr == 1
+ end
+
+ def opcode
+ @data[1].bits(11...15)
+ end
+
+ def opcode=(v)
+ mask = (1_u16 << 4) - 1
+ if 0 <= v && v <= mask
+ else
+ raise("overflow")
+ end
+ @data[1] = (@data[1] & (~(mask << 11))) | (v.to_u16 << 11)
+ end
+
+ def aa
+ @data[1].bits(10...11)
+ end
+
+ def aa=(v)
+ mask = (1_u16 << 1) - 1
+ if 0 <= v && v <= mask
+ else
+ raise("overflow")
+ end
+ @data[1] = (@data[1] & (~(mask << 10))) | (v.to_u16 << 10)
+ end
+
+ def aa=(v : Bool)
+ self.aa = v ? 1 : 0
+ end
+
+ def aa?
+ self.aa == 1
+ end
+
+ def tc
+ @data[1].bits(9...10)
+ end
+
+ def tc=(v)
+ mask = (1_u16 << 1) - 1
+ if 0 <= v && v <= mask
+ else
+ raise("overflow")
+ end
+ @data[1] = (@data[1] & (~(mask << 9))) | (v.to_u16 << 9)
+ end
+
+ def tc=(v : Bool)
+ self.tc = v ? 1 : 0
+ end
+
+ def tc?
+ self.tc == 1
+ end
+
+ def rd
+ @data[1].bits(8...9)
+ end
+
+ def rd=(v)
+ mask = (1_u16 << 1) - 1
+ if 0 <= v && v <= mask
+ else
+ raise("overflow")
+ end
+ @data[1] = (@data[1] & (~(mask << 8))) | (v.to_u16 << 8)
+ end
+
+ def rd=(v : Bool)
+ self.rd = v ? 1 : 0
+ end
+
+ def rd?
+ self.rd == 1
+ end
+
+ def ra
+ @data[1].bits(7...8)
+ end
+
+ def ra=(v)
+ mask = (1_u16 << 1) - 1
+ if 0 <= v && v <= mask
+ else
+ raise("overflow")
+ end
+ @data[1] = (@data[1] & (~(mask << 7))) | (v.to_u16 << 7)
+ end
+
+ def ra=(v : Bool)
+ self.ra = v ? 1 : 0
+ end
+
+ def ra?
+ self.ra == 1
+ end
+
+ def z
+ @data[1].bits(4...7)
+ end
+
+ def z=(v)
+ mask = (1_u16 << 3) - 1
+ if 0 <= v && v <= mask
+ else
+ raise("overflow")
+ end
+ @data[1] = (@data[1] & (~(mask << 4))) | (v.to_u16 << 4)
+ end
+
+ def rcode
+ @data[1].bits(0...4)
+ end
+
+ def rcode=(v)
+ mask = (1_u16 << 4) - 1
+ if 0 <= v && v <= mask
+ else
+ raise("overflow")
+ end
+ @data[1] = (@data[1] & (~(mask << 0))) | (v.to_u16 << 0)
+ end
+
+ def qdcount
+ @data[2]
+ end
+
+ def qdcount=(v)
+ @data[2] = v.to_u16
+ end
+
+ def ancount
+ @data[3]
+ end
+
+ def ancount=(v)
+ @data[3] = v.to_u16
+ end
+
+ def nscount
+ @data[4]
+ end
+
+ def nscount=(v)
+ @data[4] = v.to_u16
+ end
+
+ def arcount
+ @data[5]
+ end
+
+ def arcount=(v)
+ @data[5] = v.to_u16
+ end
+
+ def values
+ { id: self.id,
+ qr: self.qr,
+ opcode: self.opcode,
+ aa: self.aa,
+ tc: self.tc,
+ rd: self.rd,
+ ra: self.ra,
+ z: self.z,
+ rcode: self.rcode,
+ qdcount: self.qdcount,
+ ancount: self.ancount,
+ nscount: self.nscount,
+ arcount: self.arcount,
+ }
+ end
+
+ def self.field_sizes
+ { id: 16,
+ qr: 1,
+ opcode: 4,
+ aa: 1,
+ tc: 1,
+ rd: 1,
+ ra: 1,
+ z: 3,
+ rcode: 4,
+ qdcount: 16,
+ ancount: 16,
+ nscount: 16,
+ arcount: 16,
+ }
+ end
+ end
diff --git a/Task/ASCII-art-diagram-converter/Pluto/ascii-art-diagram-converter.pluto b/Task/ASCII-art-diagram-converter/Pluto/ascii-art-diagram-converter.pluto
new file mode 100644
index 0000000000..d0ab1c791b
--- /dev/null
+++ b/Task/ASCII-art-diagram-converter/Pluto/ascii-art-diagram-converter.pluto
@@ -0,0 +1,108 @@
+require "bignum"
+local fmt = require "fmt"
+
+class result
+ function __construct(public name, public size, public start, public finish)
+ end
+end
+
+local function validate(diagram)
+ local lines = {}
+ for diagram:split("\n") as line do
+ line = line:strip(" \t")
+ if line != "" then lines:insert(line) end
+ end
+ if #lines == 0 then error("diagram has no non-empty lines!") end
+ local width = #lines[1]
+ local cols = (width - 1) // 3
+ if cols != 8 and cols != 16 and cols != 32 and cols != 64 then
+ error("number of columns should be 8, 16, 32 or 64")
+ end
+ if #lines % 2 == 0 then
+ error("number of non-empty lines should be odd")
+ end
+ if lines[1] != string.rep("+--", cols) .. "+" then error("incorrect header line") end
+ local i = 0
+ for lines as line do
+ if i == 0 then
+ continue
+ elseif i % 2 == 0 then
+ if line != lines[1] then error("incorrect separator line") end
+ elseif #line != width then
+ error("inconsistent line widths")
+ elseif line[1] != "|" or line[width] != "|" then
+ error("non-separator lines must begin and end with '|'")
+ end
+ i += 1
+ end
+ return lines
+end
+
+local function decode(lines)
+ print("Name Bits Start End")
+ print("======= ==== ===== ===")
+ local start = 0
+ local width = #lines[1]
+ local results = {}
+ local i = 0
+ for lines as line do
+ if i % 2 == 0 then
+ i += 1
+ continue
+ end
+ line = line:sub(2, width - 1)
+ for line:split("|") as name do
+ local size = (#name + 1) // 3
+ name = name:strip()
+ local r = new result(name, size, start, start + size - 1)
+ results:insert(r)
+ fmt.print("%-7s %2d %3d %3d", r.name, r.size, r.start, r.finish)
+ start += size
+ end
+ i += 1
+ end
+ return results
+end
+
+local function hex2bin(hex)
+ local z = bigint.frombase(hex, 16)
+ return fmt.lpad(bigint.tobase(z, 2), 4 * #hex, "0")
+end
+
+local function unpack(results, hex)
+ print("\nTest string in hex:")
+ print(hex)
+ print("\nTest string in binary:")
+ local bin = hex2bin(hex)
+ print(bin)
+ print("\nUnpacked:\n")
+ print("Name Size Bit pattern")
+ print("======= ==== ================")
+ for results as res do
+ fmt.print("%-7s %2d %s", res.name, res.size, bin:sub(res.start + 1, res.finish + 1))
+ end
+end
+
+local diagram = [[
+ +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+ | ID |
+ +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+ |QR| Opcode |AA|TC|RD|RA| Z | RCODE |
+ +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+ | QDCOUNT |
+ +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+
+ | ANCOUNT |
+ +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+ | NSCOUNT |
+ +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+ | ARCOUNT |
+ +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
+]]
+local lines = validate(diagram)
+print("Diagram after trimming whitespace and removal of blank lines:\n")
+for lines as line do print(line) end
+print("\nDecoded:\n")
+local results = decode(lines)
+local hex = "78477bbf5496e12e1bf169a4" -- test string
+unpack(results, hex)
diff --git a/Task/AVL-tree/Ada/avl-tree.adb b/Task/AVL-tree/Ada/avl-tree.adb
new file mode 100644
index 0000000000..23f26aef02
--- /dev/null
+++ b/Task/AVL-tree/Ada/avl-tree.adb
@@ -0,0 +1,241 @@
+with Ada.Text_IO, Ada.Finalization, Ada.Unchecked_Deallocation;
+
+procedure Main is
+
+ generic
+ type Key_Type is private;
+ with function "<"(a, b : Key_Type) return Boolean is <>;
+ with function "="(a, b : Key_Type) return Boolean is <>;
+ with function "<="(a, b : Key_Type) return Boolean is <>;
+ package AVL_Tree is
+ type Tree is tagged limited private;
+ function insert(self : in out Tree; key : Key_Type) return Boolean;
+ procedure delete(self : in out Tree; key : Key_Type);
+ procedure print_balance(self : in out Tree);
+
+ private
+ type Height_Amt is range -1 .. Integer'Last;
+
+ -- Since only one key is inserted before each rebalance, the balance of
+ -- all trees/subtrees will stay in range -2 .. 2
+ type Balance_Amt is range -2 .. 2;
+
+ type Node;
+ type Node_Ptr is access Node;
+ type Node is new Ada.Finalization.Limited_Controlled with record
+ left, right, parent : Node_Ptr := null;
+ key : Key_Type;
+ balance : Balance_Amt := 0;
+ end record;
+ overriding procedure Finalize(self : in out Node);
+ subtype Node_Parent is Ada.Finalization.Limited_Controlled;
+
+ type Tree is new Ada.Finalization.Limited_Controlled with record
+ root : Node_Ptr := null;
+ end record;
+ overriding procedure Finalize(self : in out Tree);
+
+ end AVL_Tree;
+
+ package body AVL_Tree is
+
+ procedure Free_Node is new Ada.Unchecked_Deallocation(Node, Node_Ptr);
+
+ overriding procedure Finalize(self : in out Node) is
+ begin
+ Free_Node(self.left);
+ Free_Node(self.right);
+ end Finalize;
+
+ overriding procedure Finalize(self : in out Tree) is
+ begin
+ Free_Node(self.root);
+ end Finalize;
+
+
+ function height(n : Node_Ptr) return Height_Amt is
+ begin
+ if n = null then
+ return -1;
+ else
+ return 1 + Height_Amt'Max(height(n.left), height(n.right));
+ end if;
+ end height;
+
+ procedure set_balance(n : not null Node_Ptr) is
+ begin
+ n.balance := Balance_Amt(height(n.right) - height(n.left));
+ end set_balance;
+
+ procedure update_parent(parent : Node_Ptr; new_child : Node_Ptr; old_child : Node_Ptr) is
+ begin
+ if parent /= null then
+ if parent.right = old_child then
+ parent.right := new_child;
+ else
+ parent.left := new_child;
+ end if;
+ end if;
+ end update_parent;
+
+ function rotate_left(a : not null Node_Ptr) return Node_Ptr is
+ b : Node_Ptr := a.right;
+ begin
+ b.parent := a.parent;
+ a.right := b.left;
+ if a.right /= null then
+ a.right.parent := a;
+ end if;
+ b.left := a;
+ a.parent := b;
+ update_parent(parent => b.parent, new_child => b, old_child => a);
+
+ set_balance(a);
+ set_balance(b);
+ return b;
+ end rotate_left;
+
+ function rotate_right(a : not null Node_Ptr) return Node_Ptr is
+ b : Node_Ptr := a.left;
+ begin
+ b.parent := a.parent;
+ a.left := b.right;
+ if a.left /= null then
+ a.left.parent := a;
+ end if;
+ b.right := a;
+ a.parent := b;
+ update_parent(parent => b.parent, new_child => b, old_child => a);
+
+ set_balance(a);
+ set_balance(b);
+ return b;
+ end rotate_right;
+
+ function rotate_left_right(n : not null Node_Ptr) return Node_Ptr is
+ begin
+ n.left := rotate_left(n.left);
+ return rotate_right(n);
+ end rotate_left_right;
+
+ function rotate_right_left(n : not null Node_Ptr) return Node_Ptr is
+ begin
+ n.right := rotate_right(n.right);
+ return rotate_left(n);
+ end rotate_right_left;
+
+ procedure rebalance(self : in out Tree; n : not null Node_Ptr) is
+ new_n : Node_Ptr := n;
+ begin
+ set_balance(new_n);
+ if new_n.balance = -2 then
+ if height(new_n.left.left) >= height(new_n.left.right) then
+ new_n := rotate_right(new_n);
+ else
+ new_n := rotate_left_right(new_n);
+ end if;
+ elsif new_n.balance = 2 then
+ if height(new_n.right.right) >= height(new_n.right.left) then
+ new_n := rotate_left(new_n);
+ else
+ new_n := rotate_right_left(new_n);
+ end if;
+ end if;
+
+ if new_n.parent /= null then
+ rebalance(self, new_n.parent);
+ else
+ self.root := new_n;
+ end if;
+ end rebalance;
+
+ function new_node(key : Key_Type) return Node_Ptr is
+ (new Node'(Node_Parent with key => key, others => <>));
+
+ function insert(self : in out Tree; key : Key_Type) return Boolean is
+ curr, parent : Node_Ptr;
+ go_left : Boolean;
+ begin
+ if self.root = null then
+ self.root := new_node(key);
+ return True;
+ end if;
+
+ curr := self.root;
+ while curr.key /= key loop
+ parent := curr;
+ go_left := key < curr.key;
+ curr := (if go_left then curr.left else curr.right);
+ if curr = null then
+ if go_left then
+ parent.left := new_node(key);
+ parent.left.parent := parent;
+ else
+ parent.right := new_node(key);
+ parent.right.parent := parent;
+ end if;
+ rebalance(self, parent);
+ return True;
+ end if;
+ end loop;
+ return False;
+ end insert;
+
+ procedure delete(self : in out Tree; key : Key_Type) is
+ successor, parent, child : Node_Ptr := self.root;
+ to_delete : Node_Ptr := null;
+ begin
+ if self.root = null then
+ return;
+ end if;
+
+ while child /= null loop
+ parent := successor;
+ successor := child;
+ child := (if successor.key <= key then successor.right else successor.left);
+ if successor.key = key then
+ to_delete := successor;
+ end if;
+ end loop;
+
+ if to_delete = null then
+ return;
+ end if;
+ to_delete.key := successor.key;
+ child := (if successor.left = null then successor.right else successor.left);
+ if self.root.key = key then
+ self.root := child;
+ else
+ update_parent(parent => parent, new_child => child, old_child => successor);
+ rebalance(self, parent);
+ end if;
+ Free_Node(successor);
+ end delete;
+
+ procedure print_balance(n : Node_Ptr) is
+ begin
+ if n /= null then
+ print_balance(n.left);
+ Ada.Text_IO.Put(n.balance'Image);
+ print_balance(n.right);
+ end if;
+ end print_balance;
+
+ procedure print_balance(self : in out Tree) is
+ begin
+ print_balance(self.root);
+ end print_balance;
+ end AVL_Tree;
+
+ package Int_AVL_Tree is new AVL_Tree(Integer);
+
+ tree : Int_AVL_Tree.Tree;
+ success : Boolean;
+begin
+ for i in 1 .. 10 loop
+ success := tree.insert(i);
+ end loop;
+ Ada.Text_IO.Put("Printing balance: ");
+ tree.print_balance;
+ Ada.Text_IO.New_Line;
+end Main;
diff --git a/Task/AVL-tree/COBOL/avl-tree.cob b/Task/AVL-tree/COBOL/avl-tree.cob
new file mode 100644
index 0000000000..48796414fd
--- /dev/null
+++ b/Task/AVL-tree/COBOL/avl-tree.cob
@@ -0,0 +1,515 @@
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. AVL-TREE.
+
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+
+*>--------------------------------------------------------
+*> Node pool - array-based tree storage (0 = null)
+*>--------------------------------------------------------
+ 01 WS-NODE-COUNT PIC 9(4) VALUE 0.
+ 01 WS-ROOT PIC 9(4) VALUE 0.
+
+ 01 WS-NODE-TABLE.
+ 05 WS-NODES OCCURS 1000 TIMES.
+ 10 WS-N-KEY PIC S9(8) VALUE 0.
+ 10 WS-N-BAL PIC S9(4) VALUE 0.
+ 10 WS-N-HGT PIC S9(4) VALUE 0.
+ 10 WS-N-LEFT PIC 9(4) VALUE 0.
+ 10 WS-N-RIGHT PIC 9(4) VALUE 0.
+ 10 WS-N-PARENT PIC 9(4) VALUE 0.
+
+*>--------------------------------------------------------
+*> Subroutine parameters and return values
+*>--------------------------------------------------------
+ 01 WS-INSERT-KEY PIC S9(8).
+ 01 WS-INSERT-OK PIC 9 VALUE 0.
+ 88 INSERT-SUCCESS VALUE 1.
+ 88 INSERT-FAILURE VALUE 0.
+
+ 01 WS-DELETE-KEY PIC S9(8).
+
+ 01 WS-NEW-IDX PIC 9(4).
+ 01 WS-ALLOC-KEY PIC S9(8).
+ 01 WS-ALLOC-PARENT PIC 9(4).
+
+ 01 WS-ROT-A PIC 9(4).
+ 01 WS-ROT-B PIC 9(4).
+ 01 WS-ROT-RESULT PIC 9(4).
+
+ 01 WS-HGT-IDX PIC 9(4).
+ 01 WS-HGT-RESULT PIC S9(4).
+
+ 01 WS-SETBAL-IDX PIC 9(4).
+
+ 01 WS-RB-IDX PIC 9(4).
+
+*>--------------------------------------------------------
+*> Internal working variables
+*>--------------------------------------------------------
+ 01 WS-CURR-IDX PIC 9(4).
+ 01 WS-PARENT-IDX PIC 9(4).
+ 01 WS-GO-LEFT PIC 9 VALUE 0.
+ 88 GOING-LEFT VALUE 1.
+ 88 GOING-RIGHT VALUE 0.
+
+ 01 WS-TEMP-IDX PIC 9(4).
+ 01 WS-HEIGHT-LL PIC S9(4).
+ 01 WS-HEIGHT-LR PIC S9(4).
+ 01 WS-HEIGHT-RL PIC S9(4).
+ 01 WS-HEIGHT-RR PIC S9(4).
+ 01 WS-HGT-LEFT PIC S9(4).
+ 01 WS-HGT-RIGHT PIC S9(4).
+ 01 WS-MAX-HGT PIC S9(4).
+
+ 01 WS-DEL-NODE PIC 9(4).
+ 01 WS-DEL-CHILD PIC 9(4).
+ 01 WS-DEL-PARENT PIC 9(4).
+ 01 WS-SEARCH-IDX PIC 9(4).
+
+*>--------------------------------------------------------
+*> Print balance - iterative in-order traversal stack
+*>--------------------------------------------------------
+ 01 WS-PB-CURR PIC 9(4).
+ 01 WS-PB-TOP PIC 9(4) VALUE 0.
+ 01 WS-PB-STACK.
+ 05 WS-PB-ITEMS OCCURS 1000 TIMES
+ PIC 9(4).
+ 01 WS-DISPLAY-BAL PIC -9.
+
+*>--------------------------------------------------------
+*> Loop counter
+*>--------------------------------------------------------
+ 01 WS-I PIC S9(8).
+
+ PROCEDURE DIVISION.
+
+*>========================================================
+ MAIN-PROGRAM.
+*>========================================================
+ DISPLAY "Inserting values 1 to 10"
+ PERFORM VARYING WS-I FROM 1 BY 1
+ UNTIL WS-I > 9
+ MOVE WS-I TO WS-INSERT-KEY
+ PERFORM INSERT-NODE
+ END-PERFORM
+
+ DISPLAY "Printing balance: " WITH NO ADVANCING
+ PERFORM PRINT-BALANCE
+ DISPLAY " "
+
+ STOP RUN
+ .
+
+*>========================================================
+*> ALLOCATE-NODE
+*> Input: WS-ALLOC-KEY, WS-ALLOC-PARENT
+*> Output: WS-NEW-IDX
+*>========================================================
+ ALLOCATE-NODE.
+ ADD 1 TO WS-NODE-COUNT
+ MOVE WS-NODE-COUNT TO WS-NEW-IDX
+ MOVE WS-ALLOC-KEY TO WS-N-KEY(WS-NEW-IDX)
+ MOVE 0 TO WS-N-BAL(WS-NEW-IDX)
+ MOVE 0 TO WS-N-HGT(WS-NEW-IDX)
+ MOVE 0 TO WS-N-LEFT(WS-NEW-IDX)
+ MOVE 0 TO WS-N-RIGHT(WS-NEW-IDX)
+ MOVE WS-ALLOC-PARENT TO WS-N-PARENT(WS-NEW-IDX)
+ .
+
+*>========================================================
+*> INSERT-NODE
+*> Input: WS-INSERT-KEY
+*> Output: WS-INSERT-OK (1=success, 0=duplicate)
+*>========================================================
+ INSERT-NODE.
+ SET INSERT-FAILURE TO TRUE
+
+ IF WS-ROOT = 0
+ MOVE WS-INSERT-KEY TO WS-ALLOC-KEY
+ MOVE 0 TO WS-ALLOC-PARENT
+ PERFORM ALLOCATE-NODE
+ MOVE WS-NEW-IDX TO WS-ROOT
+ SET INSERT-SUCCESS TO TRUE
+ ELSE
+ MOVE WS-ROOT TO WS-CURR-IDX
+ PERFORM INSERT-SEARCH
+ UNTIL WS-CURR-IDX = 0
+ OR INSERT-SUCCESS
+ END-IF
+ .
+
+ INSERT-SEARCH.
+ IF WS-N-KEY(WS-CURR-IDX) = WS-INSERT-KEY
+ SET INSERT-FAILURE TO TRUE
+ MOVE 0 TO WS-CURR-IDX
+ ELSE
+ MOVE WS-CURR-IDX TO WS-PARENT-IDX
+ IF WS-N-KEY(WS-CURR-IDX) > WS-INSERT-KEY
+ SET GOING-LEFT TO TRUE
+ MOVE WS-N-LEFT(WS-CURR-IDX)
+ TO WS-CURR-IDX
+ ELSE
+ SET GOING-RIGHT TO TRUE
+ MOVE WS-N-RIGHT(WS-CURR-IDX)
+ TO WS-CURR-IDX
+ END-IF
+
+ IF WS-CURR-IDX = 0
+ MOVE WS-INSERT-KEY TO WS-ALLOC-KEY
+ MOVE WS-PARENT-IDX TO WS-ALLOC-PARENT
+ PERFORM ALLOCATE-NODE
+ IF GOING-LEFT
+ MOVE WS-NEW-IDX
+ TO WS-N-LEFT(WS-PARENT-IDX)
+ ELSE
+ MOVE WS-NEW-IDX
+ TO WS-N-RIGHT(WS-PARENT-IDX)
+ END-IF
+ MOVE WS-PARENT-IDX TO WS-RB-IDX
+ PERFORM REBALANCE
+ SET INSERT-SUCCESS TO TRUE
+ END-IF
+ END-IF
+ .
+
+*>========================================================
+*> DELETE-BY-KEY
+*> Input: WS-DELETE-KEY
+*>========================================================
+ DELETE-BY-KEY.
+ IF WS-ROOT NOT = 0
+ MOVE WS-ROOT TO WS-SEARCH-IDX
+ PERFORM DELETE-KEY-SEARCH
+ UNTIL WS-SEARCH-IDX = 0
+ END-IF
+ .
+
+ DELETE-KEY-SEARCH.
+ MOVE WS-SEARCH-IDX TO WS-DEL-NODE
+ IF WS-DELETE-KEY >= WS-N-KEY(WS-DEL-NODE)
+ MOVE WS-N-RIGHT(WS-DEL-NODE)
+ TO WS-SEARCH-IDX
+ ELSE
+ MOVE WS-N-LEFT(WS-DEL-NODE)
+ TO WS-SEARCH-IDX
+ END-IF
+
+ IF WS-DELETE-KEY = WS-N-KEY(WS-DEL-NODE)
+ PERFORM DELETE-NODE
+ MOVE 0 TO WS-SEARCH-IDX
+ END-IF
+ .
+
+*>========================================================
+*> DELETE-NODE (iterative replacement of Java recursion)
+*> Input: WS-DEL-NODE
+*>========================================================
+ DELETE-NODE.
+*> Swap key with predecessor/successor until leaf
+ PERFORM UNTIL WS-N-LEFT(WS-DEL-NODE) = 0
+ AND WS-N-RIGHT(WS-DEL-NODE) = 0
+
+ IF WS-N-LEFT(WS-DEL-NODE) NOT = 0
+ MOVE WS-N-LEFT(WS-DEL-NODE)
+ TO WS-DEL-CHILD
+ PERFORM UNTIL
+ WS-N-RIGHT(WS-DEL-CHILD) = 0
+ MOVE WS-N-RIGHT(WS-DEL-CHILD)
+ TO WS-DEL-CHILD
+ END-PERFORM
+ ELSE
+ MOVE WS-N-RIGHT(WS-DEL-NODE)
+ TO WS-DEL-CHILD
+ PERFORM UNTIL
+ WS-N-LEFT(WS-DEL-CHILD) = 0
+ MOVE WS-N-LEFT(WS-DEL-CHILD)
+ TO WS-DEL-CHILD
+ END-PERFORM
+ END-IF
+
+ MOVE WS-N-KEY(WS-DEL-CHILD)
+ TO WS-N-KEY(WS-DEL-NODE)
+ MOVE WS-DEL-CHILD TO WS-DEL-NODE
+
+ END-PERFORM
+
+*> Now WS-DEL-NODE is a leaf - remove it
+ IF WS-N-PARENT(WS-DEL-NODE) = 0
+ MOVE 0 TO WS-ROOT
+ ELSE
+ MOVE WS-N-PARENT(WS-DEL-NODE)
+ TO WS-DEL-PARENT
+ IF WS-N-LEFT(WS-DEL-PARENT) = WS-DEL-NODE
+ MOVE 0 TO WS-N-LEFT(WS-DEL-PARENT)
+ ELSE
+ MOVE 0 TO WS-N-RIGHT(WS-DEL-PARENT)
+ END-IF
+ MOVE WS-DEL-PARENT TO WS-RB-IDX
+ PERFORM REBALANCE
+ END-IF
+ .
+
+*>========================================================
+*> REBALANCE (iterative - walks up to root)
+*> Input: WS-RB-IDX
+*>========================================================
+ REBALANCE.
+ PERFORM REBALANCE-STEP
+ UNTIL WS-RB-IDX = 0
+ .
+
+ REBALANCE-STEP.
+ MOVE WS-RB-IDX TO WS-SETBAL-IDX
+ PERFORM SET-BALANCE
+
+ EVALUATE TRUE
+
+ WHEN WS-N-BAL(WS-RB-IDX) = -2
+ MOVE WS-N-LEFT(WS-RB-IDX)
+ TO WS-TEMP-IDX
+ MOVE WS-N-LEFT(WS-TEMP-IDX)
+ TO WS-HGT-IDX
+ PERFORM GET-HEIGHT
+ MOVE WS-HGT-RESULT TO WS-HEIGHT-LL
+ MOVE WS-N-RIGHT(WS-TEMP-IDX)
+ TO WS-HGT-IDX
+ PERFORM GET-HEIGHT
+ MOVE WS-HGT-RESULT TO WS-HEIGHT-LR
+ IF WS-HEIGHT-LL >= WS-HEIGHT-LR
+*> rotateRight(n)
+ MOVE WS-RB-IDX TO WS-ROT-A
+ PERFORM ROTATE-RIGHT
+ MOVE WS-ROT-RESULT TO WS-RB-IDX
+ ELSE
+*> rotateLeftThenRight(n)
+ MOVE WS-N-LEFT(WS-RB-IDX)
+ TO WS-ROT-A
+ PERFORM ROTATE-LEFT
+ MOVE WS-ROT-RESULT
+ TO WS-N-LEFT(WS-RB-IDX)
+ MOVE WS-RB-IDX TO WS-ROT-A
+ PERFORM ROTATE-RIGHT
+ MOVE WS-ROT-RESULT TO WS-RB-IDX
+ END-IF
+
+ WHEN WS-N-BAL(WS-RB-IDX) = 2
+ MOVE WS-N-RIGHT(WS-RB-IDX)
+ TO WS-TEMP-IDX
+ MOVE WS-N-RIGHT(WS-TEMP-IDX)
+ TO WS-HGT-IDX
+ PERFORM GET-HEIGHT
+ MOVE WS-HGT-RESULT TO WS-HEIGHT-RR
+ MOVE WS-N-LEFT(WS-TEMP-IDX)
+ TO WS-HGT-IDX
+ PERFORM GET-HEIGHT
+ MOVE WS-HGT-RESULT TO WS-HEIGHT-RL
+ IF WS-HEIGHT-RR >= WS-HEIGHT-RL
+*> rotateLeft(n)
+ MOVE WS-RB-IDX TO WS-ROT-A
+ PERFORM ROTATE-LEFT
+ MOVE WS-ROT-RESULT TO WS-RB-IDX
+ ELSE
+*> rotateRightThenLeft(n)
+ MOVE WS-N-RIGHT(WS-RB-IDX)
+ TO WS-ROT-A
+ PERFORM ROTATE-RIGHT
+ MOVE WS-ROT-RESULT
+ TO WS-N-RIGHT(WS-RB-IDX)
+ MOVE WS-RB-IDX TO WS-ROT-A
+ PERFORM ROTATE-LEFT
+ MOVE WS-ROT-RESULT TO WS-RB-IDX
+ END-IF
+
+ WHEN OTHER
+ CONTINUE
+
+ END-EVALUATE
+
+ IF WS-N-PARENT(WS-RB-IDX) NOT = 0
+ MOVE WS-N-PARENT(WS-RB-IDX) TO WS-RB-IDX
+ ELSE
+ MOVE WS-RB-IDX TO WS-ROOT
+ MOVE 0 TO WS-RB-IDX
+ END-IF
+ .
+
+*>========================================================
+*> ROTATE-LEFT
+*> Input: WS-ROT-A
+*> Output: WS-ROT-RESULT
+*>========================================================
+ ROTATE-LEFT.
+*> Node b = a.right
+ MOVE WS-N-RIGHT(WS-ROT-A) TO WS-ROT-B
+*> b.parent = a.parent
+ MOVE WS-N-PARENT(WS-ROT-A)
+ TO WS-N-PARENT(WS-ROT-B)
+*> a.right = b.left
+ MOVE WS-N-LEFT(WS-ROT-B)
+ TO WS-N-RIGHT(WS-ROT-A)
+*> if (a.right != null) a.right.parent = a
+ IF WS-N-RIGHT(WS-ROT-A) NOT = 0
+ MOVE WS-N-RIGHT(WS-ROT-A) TO WS-TEMP-IDX
+ MOVE WS-ROT-A
+ TO WS-N-PARENT(WS-TEMP-IDX)
+ END-IF
+*> b.left = a
+ MOVE WS-ROT-A TO WS-N-LEFT(WS-ROT-B)
+*> a.parent = b
+ MOVE WS-ROT-B TO WS-N-PARENT(WS-ROT-A)
+*> if (b.parent != null) { fix parent's child ptr }
+ IF WS-N-PARENT(WS-ROT-B) NOT = 0
+ MOVE WS-N-PARENT(WS-ROT-B) TO WS-TEMP-IDX
+ IF WS-N-RIGHT(WS-TEMP-IDX) = WS-ROT-A
+ MOVE WS-ROT-B
+ TO WS-N-RIGHT(WS-TEMP-IDX)
+ ELSE
+ MOVE WS-ROT-B
+ TO WS-N-LEFT(WS-TEMP-IDX)
+ END-IF
+ END-IF
+*> setBalance(a, b)
+ MOVE WS-ROT-A TO WS-SETBAL-IDX
+ PERFORM SET-BALANCE
+ MOVE WS-ROT-B TO WS-SETBAL-IDX
+ PERFORM SET-BALANCE
+*> return b
+ MOVE WS-ROT-B TO WS-ROT-RESULT
+ .
+
+*>========================================================
+*> ROTATE-RIGHT
+*> Input: WS-ROT-A
+*> Output: WS-ROT-RESULT
+*>========================================================
+ ROTATE-RIGHT.
+*> Node b = a.left
+ MOVE WS-N-LEFT(WS-ROT-A) TO WS-ROT-B
+*> b.parent = a.parent
+ MOVE WS-N-PARENT(WS-ROT-A)
+ TO WS-N-PARENT(WS-ROT-B)
+*> a.left = b.right
+ MOVE WS-N-RIGHT(WS-ROT-B)
+ TO WS-N-LEFT(WS-ROT-A)
+*> if (a.left != null) a.left.parent = a
+ IF WS-N-LEFT(WS-ROT-A) NOT = 0
+ MOVE WS-N-LEFT(WS-ROT-A) TO WS-TEMP-IDX
+ MOVE WS-ROT-A
+ TO WS-N-PARENT(WS-TEMP-IDX)
+ END-IF
+*> b.right = a
+ MOVE WS-ROT-A TO WS-N-RIGHT(WS-ROT-B)
+*> a.parent = b
+ MOVE WS-ROT-B TO WS-N-PARENT(WS-ROT-A)
+*> if (b.parent != null) { fix parent's child ptr }
+ IF WS-N-PARENT(WS-ROT-B) NOT = 0
+ MOVE WS-N-PARENT(WS-ROT-B) TO WS-TEMP-IDX
+ IF WS-N-RIGHT(WS-TEMP-IDX) = WS-ROT-A
+ MOVE WS-ROT-B
+ TO WS-N-RIGHT(WS-TEMP-IDX)
+ ELSE
+ MOVE WS-ROT-B
+ TO WS-N-LEFT(WS-TEMP-IDX)
+ END-IF
+ END-IF
+*> setBalance(a, b)
+ MOVE WS-ROT-A TO WS-SETBAL-IDX
+ PERFORM SET-BALANCE
+ MOVE WS-ROT-B TO WS-SETBAL-IDX
+ PERFORM SET-BALANCE
+*> return b
+ MOVE WS-ROT-B TO WS-ROT-RESULT
+ .
+
+*>========================================================
+*> GET-HEIGHT
+*> Input: WS-HGT-IDX (0 = null node)
+*> Output: WS-HGT-RESULT
+*>========================================================
+ GET-HEIGHT.
+ IF WS-HGT-IDX = 0
+ MOVE -1 TO WS-HGT-RESULT
+ ELSE
+ MOVE WS-N-HGT(WS-HGT-IDX)
+ TO WS-HGT-RESULT
+ END-IF
+ .
+
+*>========================================================
+*> SET-BALANCE
+*> Input: WS-SETBAL-IDX
+*>========================================================
+ SET-BALANCE.
+ PERFORM REHEIGHT
+
+ MOVE WS-N-RIGHT(WS-SETBAL-IDX) TO WS-HGT-IDX
+ PERFORM GET-HEIGHT
+ MOVE WS-HGT-RESULT TO WS-HGT-RIGHT
+
+ MOVE WS-N-LEFT(WS-SETBAL-IDX) TO WS-HGT-IDX
+ PERFORM GET-HEIGHT
+ MOVE WS-HGT-RESULT TO WS-HGT-LEFT
+
+ SUBTRACT WS-HGT-LEFT FROM WS-HGT-RIGHT
+ GIVING WS-N-BAL(WS-SETBAL-IDX)
+ .
+
+*>========================================================
+*> REHEIGHT
+*> Input: WS-SETBAL-IDX
+*>========================================================
+ REHEIGHT.
+ IF WS-SETBAL-IDX NOT = 0
+ MOVE WS-N-LEFT(WS-SETBAL-IDX) TO WS-HGT-IDX
+ PERFORM GET-HEIGHT
+ MOVE WS-HGT-RESULT TO WS-HGT-LEFT
+
+ MOVE WS-N-RIGHT(WS-SETBAL-IDX) TO WS-HGT-IDX
+ PERFORM GET-HEIGHT
+ MOVE WS-HGT-RESULT TO WS-HGT-RIGHT
+
+ IF WS-HGT-LEFT > WS-HGT-RIGHT
+ MOVE WS-HGT-LEFT TO WS-MAX-HGT
+ ELSE
+ MOVE WS-HGT-RIGHT TO WS-MAX-HGT
+ END-IF
+
+ ADD 1 TO WS-MAX-HGT
+ MOVE WS-MAX-HGT
+ TO WS-N-HGT(WS-SETBAL-IDX)
+ END-IF
+ .
+
+*>========================================================
+*> PRINT-BALANCE (iterative in-order traversal)
+*>========================================================
+ PRINT-BALANCE.
+ MOVE 0 TO WS-PB-TOP
+ MOVE WS-ROOT TO WS-PB-CURR
+
+ PERFORM UNTIL WS-PB-CURR = 0
+ AND WS-PB-TOP = 0
+
+ PERFORM UNTIL WS-PB-CURR = 0
+ ADD 1 TO WS-PB-TOP
+ MOVE WS-PB-CURR
+ TO WS-PB-ITEMS(WS-PB-TOP)
+ MOVE WS-N-LEFT(WS-PB-CURR)
+ TO WS-PB-CURR
+ END-PERFORM
+
+ IF WS-PB-TOP > 0
+ MOVE WS-PB-ITEMS(WS-PB-TOP)
+ TO WS-PB-CURR
+ SUBTRACT 1 FROM WS-PB-TOP
+ MOVE WS-N-BAL(WS-PB-CURR)
+ TO WS-DISPLAY-BAL
+ DISPLAY WS-DISPLAY-BAL " "
+ WITH NO ADVANCING
+ MOVE WS-N-RIGHT(WS-PB-CURR)
+ TO WS-PB-CURR
+ END-IF
+
+ END-PERFORM
+ .
diff --git a/Task/AVL-tree/Emacs-Lisp/avl-tree.el b/Task/AVL-tree/Emacs-Lisp/avl-tree.el
new file mode 100644
index 0000000000..f639c21adc
--- /dev/null
+++ b/Task/AVL-tree/Emacs-Lisp/avl-tree.el
@@ -0,0 +1,212 @@
+(defvar avl-all-nodes (make-vector 100 nil))
+(defvar avl-root-node nil "root node")
+
+(defun avl-create-node (key parent)
+ (copy-tree `((:key . ,key) (:balance . nil) (:height . nil)
+ (:left . nil) (:right . nil) (:parent . ,parent))))
+
+(defun avl-node (pos)
+ (if (or (null pos) (> pos (1- (length avl-all-nodes))))
+ nil
+ (aref avl-all-nodes pos)))
+
+(defun avl-node-prop (noderef &rest props)
+ (if (null noderef)
+ nil
+ (progn
+ ;;(when (integerp noderef) (setq node (avl-node node)))
+ (let ((val noderef))
+ (dolist (prop props)
+ (if (null (avl-node val))
+ (setq val nil)
+ (progn
+ (setq val (alist-get prop (avl-node val))))))
+ val)
+ )
+ )
+ )
+
+
+(defun avl-set-prop (node &rest props-and-value)
+ (when (integerp node) (setq node (avl-node node)))
+ (when (< (length props-and-value) 2)
+ (error "Both property name and value must be given."))
+ (let (noderef (props (seq-take props-and-value (1- (length props-and-value))))
+ (value (seq-elt props-and-value (1- (length props-and-value)))))
+ (when (> (length props) 0)
+ (dolist (prop (seq-take props (1- (length props))))
+ (if (null node)
+ (progn (setq noderef nil) (setq node nil))
+ (progn
+ (setq noderef (alist-get prop node))
+ (setq node (avl-node noderef))))))
+
+ (if (or (null (last props)) (null node))
+ nil
+ (setcdr (assoc (car (last props)) node) value))))
+
+
+(defun avl-height (noderef)
+ (or (avl-node-prop noderef :height) -1))
+
+(defun avl-reheight (noderef)
+ (if (null noderef)
+ nil
+ (avl-set-prop noderef :height
+ (1+ (max (avl-height (avl-node-prop noderef :left))
+ (avl-height (avl-node-prop noderef :right)))))))
+
+(defun avl-setbalance (noderef)
+ ;;(when (integerp node) (setq node (avl-node node)))
+ (avl-reheight noderef)
+ (avl-set-prop noderef :balance
+ (- (avl-height (avl-node-prop noderef :right))
+ (avl-height (avl-node-prop noderef :left)))))
+
+(defun avl-add-node (key parent)
+ (let (result (idx 0))
+ (cl-loop for idx from 0 to (1- (seq-length avl-all-nodes))
+ while (null result) do
+ (when (null (aref avl-all-nodes idx))
+ (aset avl-all-nodes idx (avl-create-node key parent))
+ (setq result idx)))
+ result))
+
+(defun avl-insert (key)
+ (if (null avl-root-node)
+ (progn (setq avl-root-node (avl-add-node key nil)) avl-root-node)
+ (progn
+ (let ((n avl-root-node) (end-loop nil) parent go-left result)
+ (while (not end-loop)
+ (if (equal key (avl-node-prop n :key))
+ (setq end-loop 't)
+ (progn
+ (setq parent n)
+ (setq go-left (> (avl-node-prop n :key) key))
+ (setq n (if go-left
+ (avl-node-prop n :left)
+ (avl-node-prop n :right)))
+
+ (when (null n)
+ (setq result (avl-add-node key parent))
+ (if go-left
+ (progn
+ (avl-set-prop parent :left result))
+ (progn
+ (avl-set-prop parent :right result)))
+ (avl-rebalance parent) ;;rebalance
+ (setq end-loop 't)))))
+ result))))
+
+
+(defun avl-rotate-left (noderef)
+ (when (not (integerp noderef)) (error "parameter must be an integer"))
+ (let ((a noderef) b)
+ (setq b (avl-node-prop a :right))
+ (avl-set-prop b :parent (avl-node-prop a :parent))
+
+ (avl-set-prop a :right (avl-node-prop b :left))
+
+ (when (avl-node-prop a :right) (avl-set-prop a :right :parent a))
+
+ (avl-set-prop b :left a)
+ (avl-set-prop a :parent b)
+
+ (when (not (null (avl-node-prop b :parent)))
+ (if (equal (avl-node-prop b :parent :right) a)
+ (avl-set-prop b :parent :right b)
+ (avl-set-prop b :parent :left b)))
+
+ (avl-setbalance a)
+ (avl-setbalance b)
+ b))
+
+
+
+(defun avl-rotate-right (node-idx)
+ (when (not (integerp node-idx)) (error "parameter must be an integer"))
+ (let ((a node-idx) b)
+ (setq b (avl-node-prop a :left))
+ (avl-set-prop b :parent (avl-node-prop a :parent))
+
+ (avl-set-prop a :left (avl-node-prop b :right))
+
+ (when (avl-node-prop a :right) (avl-set-prop a :right :parent a))
+
+ (avl-set-prop b :left a)
+ (avl-set-prop a :parent b)
+
+ (when (not (null (avl-node-prop b :parent)))
+ (if (equal (avl-node-prop b :parent :right) a)
+ (avl-set-prop b :parent :right b)
+ (avl-set-prop b :parent :left b)))
+
+ (avl-setbalance a)
+ (avl-setbalance b)
+ b))
+
+(defun avl-rotate-left-then-right (noderef)
+ (avl-set-prop noderef :left (avl-rotate-left (avl-node-prop noderef :left)))
+ (avl-rotate-right noderef))
+
+(defun avl-rotate-right-then-left (noderef)
+ (avl-set-prop noderef :right (avl-rotate-left (avl-node-prop noderef :right)))
+ (avl-rotate-left noderef))
+
+(defun avl-rebalance (noderef)
+ (avl-setbalance noderef)
+ (cond
+ ((equal -2 (avl-node-prop noderef :balance))
+ (if (>= (avl-height (avl-node-prop noderef :left :left))
+ (avl-height (avl-node-prop noderef :left :right)))
+ (setq noderef (avl-rotate-right noderef))
+ (setq noderef (avl-rotate-left-then-right noderef)))
+ )
+ ((equal 2 (avl-node-prop noderef :balance))
+ (if (>= (avl-height (avl-node-prop noderef :right :right))
+ (avl-height (avl-node-prop noderef :right :left)))
+ (setq noderef (avl-rotate-left noderef))
+ (setq noderef (avl-rotate-right-then-left noderef)))))
+
+ (if (not (null (avl-node-prop noderef :parent)))
+ (avl-rebalance (avl-node-prop noderef :parent))
+ (setq avl-root-node noderef)))
+
+
+(defun avl-delete (noderef)
+ (when noderef
+ (when (and (null (avl-node-prop noderef :left))
+ (null (avl-node-prop noderef :right)))
+ (if (null (avl-node-prop noderef :parent))
+ (setq avl-root-node nil)
+ (let ((parent (avl-node-prop noderef :parent)))
+ (if (equal noderef (avl-node-prop parent :left))
+ (avl-set-prop parent :left nil)
+ (avl-set-prop parent :right nil))
+ (avl-rebalance parent))))
+
+ (if (not (null (avl-node-prop noderef :left)))
+ (let ((child (avl-node-prop noderef :left)))
+ (while (not (null (avl-node-prop child :right)))
+ (setq child (avl-node-prop child :right)))
+ (avl-set-prop noderef :key (avl-node-prop child :key))
+ (avl-delete child))
+ (let ((child (avl-node-prop noderef :right)))
+ (while (not (null (avl-node-prop child :left)))
+ (setq child (avl-node-prop child :left)))
+ (avl-set-prop noderef :key (avl-node-prop child :key))
+ (avl-delete child)))))
+
+;; Main procedure
+(let ((cnt 10) balances)
+ (fillarray avl-all-nodes nil)
+ (setq avl-root-node nil)
+
+ (dotimes (val cnt)
+ (avl-insert (1+ val)))
+
+ (setq balances (seq-map (lambda (x) (or (avl-node-prop x :balance) 0))
+ (number-sequence 0 (1- cnt))))
+
+ (message "Inserting values 1 to %d" cnt)
+ (message "Printing balance: %s" (string-join (seq-map (lambda (x) (format "%S" x)) balances) " ")))
diff --git a/Task/Abbreviations-automatic/Ada/abbreviations-automatic.adb b/Task/Abbreviations-automatic/Ada/abbreviations-automatic.adb
new file mode 100644
index 0000000000..94a8c878f4
--- /dev/null
+++ b/Task/Abbreviations-automatic/Ada/abbreviations-automatic.adb
@@ -0,0 +1,71 @@
+with Ada.Containers.Indefinite_Vectors;
+with Ada.Strings.Fixed;
+with Ada.Strings.Maps;
+with Ada.Text_IO;
+
+procedure Abbreviations is
+
+ package String_Vectors is
+ new Ada.Containers.Indefinite_Vectors (Index_Type => Positive,
+ Element_Type => String);
+ use Ada.Text_IO, String_Vectors;
+
+ function Split (Line : String) return Vector is
+ Result : Vector;
+ First : Natural;
+ Last : Natural := Line'First - 1;
+ begin
+ while Last + 1 in Line'Range loop
+ Ada.Strings.Fixed.Find_Token
+ (Line, Ada.Strings.Maps.To_Set (" "), Last + 1,
+ Ada.Strings.Outside, First, Last);
+ exit when Last = 0;
+ Append (Result, Line (First .. Last));
+ end loop;
+ return Result;
+ end Split;
+
+ function Abbrev_Length (Items : Vector) return Natural is
+ use type Ada.Containers.Count_Type;
+ Max : Natural := 0;
+ Abbrevs : Vector;
+ begin
+ for Item of Items loop
+ Max := Natural'Max (Max, Item'Length);
+ end loop;
+
+ for Length in 1 .. Max loop
+ Abbrevs := Empty_Vector;
+ for Item of Items loop
+ declare
+ Last : constant Natural
+ := Natural'Min (Item'Last, Item'First + Length - 1);
+
+ Abbrev : String renames Item (Item'First .. Last);
+ begin
+ exit when Abbrevs.Contains (Abbrev);
+ Abbrevs.Append (Abbrev);
+ end;
+ end loop;
+ if Abbrevs.Length = Items.Length then
+ return Length;
+ end if;
+ end loop;
+ return 0;
+ end Abbrev_Length;
+
+ procedure Process (Line : String) is
+ package Natural_IO is new Ada.Text_IO.Integer_IO (Natural);
+ Words : constant Vector := Split (Line);
+ Length : constant Natural := Abbrev_Length (Words);
+ begin
+ Natural_IO.Put (Length, Width => 2);
+ Put (" ");
+ Put_Line (Line);
+ end Process;
+
+begin
+ while not End_Of_File loop
+ Process (Get_Line);
+ end loop;
+end Abbreviations;
diff --git a/Task/Abbreviations-automatic/COBOL/abbreviations-automatic.cob b/Task/Abbreviations-automatic/COBOL/abbreviations-automatic.cob
new file mode 100644
index 0000000000..617cf60927
--- /dev/null
+++ b/Task/Abbreviations-automatic/COBOL/abbreviations-automatic.cob
@@ -0,0 +1,158 @@
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. AUTO-ABBREVIATIONS.
+
+ ENVIRONMENT DIVISION.
+
+ INPUT-OUTPUT SECTION.
+ FILE-CONTROL.
+ SELECT DOW ASSIGN TO "days-of-week.txt"
+ ORGANIZATION IS LINE SEQUENTIAL.
+
+ DATA DIVISION.
+ FILE SECTION.
+ FD DOW.
+ 01 DOW-FILE PIC X(200).
+
+ WORKING-STORAGE SECTION. *> a.k.a. variables
+ 01 DOW-LINE PIC X(200).
+ 01 ENDO PIC 9(1).
+ 01 ENDO2 PIC 9(1).
+ 01 CURDAY PIC X(50).
+ 01 ABPTR PIC 999.
+ 01 LINE-NUM PIC 9(3) VALUE 1.
+ 01 CHARAMT PIC 9(3) VALUE 1.
+ 01 LARGESTCHARAMT PIC 9(3).
+ 01 DAYNUM PIC 9(3) VALUE 1.
+ 01 ABRESTART PIC 9(1).
+ 01 CURABBR PIC X(50).
+ 01 TMP1 PIC 9(3).
+ 01 TMP2 PIC 9(3).
+ 01 TINDEX PIC 9(3) VALUE 1.
+ 01 ABBRLIST.
+ 05 ABBRITEM PIC X(50) OCCURS 7 TIMES.
+
+
+ PROCEDURE DIVISION.
+ OPEN INPUT DOW.
+ PERFORM UNTIL ENDO = 1
+ READ DOW INTO DOW-LINE
+ AT END MOVE 1 TO ENDO
+ NOT AT END PERFORM
+ *> loop through each line
+ IF DOW-LINE = "" THEN
+ DISPLAY ""
+ ELSE
+ MOVE 0 TO ENDO2
+ MOVE 0 TO CHARAMT
+
+ PERFORM UNTIL ENDO2 > 0
+ MOVE 1 TO ABPTR
+ MOVE 1 TO DAYNUM
+ MOVE 0 TO ABRESTART
+
+ ADD 1 TO CHARAMT
+
+ *> reset the abbreviation table
+ MOVE 1 TO TINDEX
+ PERFORM 7 TIMES
+ MOVE SPACE TO ABBRITEM(TINDEX)
+ ADD 1 TO TINDEX
+ END-PERFORM
+
+ *> loop through each day
+ PERFORM 7 TIMES
+ UNSTRING DOW-LINE DELIMITED BY SPACE
+ INTO CURDAY
+ WITH POINTER ABPTR
+ END-UNSTRING
+
+ MOVE 0 TO TMP1
+ MOVE 0 TO TMP2
+ INSPECT CURDAY
+ TALLYING TMP1 FOR ALL CHARACTERS
+ INSPECT CURDAY
+ TALLYING TMP2 FOR ALL SPACE
+ SUBTRACT TMP2 FROM TMP1
+ IF TMP1 > LARGESTCHARAMT THEN
+ MOVE TMP1 TO LARGESTCHARAMT
+ END-IF
+
+ *> not enough days error
+ IF CURDAY = "" THEN
+ MOVE 3 TO ENDO2
+ END-IF
+
+ MOVE CURDAY(1:CHARAMT) TO CURABBR
+
+ *> check if the current abbreviation is already taken
+ MOVE 1 TO TINDEX
+ PERFORM 7 TIMES
+ IF ABBRITEM(TINDEX) = CURABBR THEN
+ MOVE 1 TO ABRESTART
+ END-IF
+ ADD 1 TO TINDEX
+ END-PERFORM
+
+ MOVE CURABBR TO ABBRITEM(DAYNUM)
+
+ ADD 1 TO DAYNUM
+
+ END-PERFORM
+
+ IF ABRESTART = 0 THEN
+ MOVE 1 TO ENDO2
+ END-IF
+
+ *> identical days error
+ IF CHARAMT > LARGESTCHARAMT THEN
+ MOVE 2 TO ENDO2
+ END-IF
+
+ END-PERFORM
+
+ DISPLAY "Line " LINE-NUM ": " WITH NO ADVANCING
+
+ IF ENDO2 = 3 THEN
+ DISPLAY "Error: not enough " WITH NO ADVANCING
+ DISPLAY "days"
+ ELSE IF ENDO2 = 2 THEN
+ DISPLAY "Error: identical " WITH NO ADVANCING
+ DISPLAY "days"
+ ELSE
+ DISPLAY CHARAMT ": " WITH NO ADVANCING
+
+ *> loop through each day and display its abbreviation
+ MOVE 1 TO TINDEX
+ PERFORM 7 TIMES
+ MOVE ABBRITEM(TINDEX) TO CURABBR
+
+ MOVE 0 TO TMP1
+ MOVE 0 TO TMP2
+ INSPECT CURABBR
+ TALLYING TMP1 FOR ALL CHARACTERS
+ INSPECT CURABBR
+ TALLYING TMP2 FOR TRAILING SPACES
+ SUBTRACT TMP2 FROM TMP1
+
+ DISPLAY CURABBR(1:TMP1) WITH NO ADVANCING
+ DISPLAY "." WITH NO ADVANCING
+
+ IF TINDEX < 7 THEN
+ DISPLAY SPACE WITH NO ADVANCING
+ ELSE
+ DISPLAY X"0a" WITH NO ADVANCING *> go to next line
+ END-IF
+
+ ADD 1 TO TINDEX
+ END-PERFORM
+ END-IF
+
+ END-IF
+
+ END-PERFORM
+ END-READ
+
+ ADD 1 TO LINE-NUM
+ END-PERFORM.
+ CLOSE DOW.
+ STOP RUN.
diff --git a/Task/Abbreviations-automatic/Emacs-Lisp/abbreviations-automatic.el b/Task/Abbreviations-automatic/Emacs-Lisp/abbreviations-automatic.el
new file mode 100644
index 0000000000..8877dc684b
--- /dev/null
+++ b/Task/Abbreviations-automatic/Emacs-Lisp/abbreviations-automatic.el
@@ -0,0 +1,36 @@
+(defun abbreviate-list (list-of-days abbreviation-length)
+ "Take each element of LIST-OF-DAYS and abbreviate to ABBREVIATION-LENGTH."
+ (let ((abbrev-list)
+ (abbrev-element))
+ (dolist (one-element list-of-days) ; loop through each day of week
+;; if the day of week is at least as long as the abbreviation
+ (if (>= (length one-element) abbreviation-length) ; if day >= abbreviation length
+ (setq abbrev-element (substring one-element 0 abbreviation-length)) ; abbreviate the day of the week
+ (setq abbrev-element one-element)) ; otherwise don't abbreviate
+ (push abbrev-element abbrev-list)) ; put the abbreviated/non-abbreviated day on our list
+ abbrev-list)) ; return the list of abbreviated days
+
+(defun cycle-days (list-of-days)
+ "Find shortest unique abbreviation in LIST-OF-DAYS list."
+ (let ((abbrev-list)
+ (abbrev-length 1)
+ (current-abbrev)
+ (looking-for-shortest-list t))
+ (if (= (length list-of-days) 0) ; if list-of-days is empty (i.e., blank line)
+ (setq looking-for-shortest-list nil)) ; then don't look for the shortest unique abbreviations
+ (while looking-for-shortest-list ; as long as we are looking for the shortest unique abbreviations
+ (setq abbrev-list (abbreviate-list list-of-days abbrev-length)) ; get a list of abbreviated day names
+ (if (= (length list-of-days) (length (seq-uniq abbrev-list))) ; if abbreviated list has no duplicates
+ (progn
+ (message (format "%d %s" abbrev-length list-of-days)) ; then in echo buffer show length and days
+ (setq looking-for-shortest-list nil)) ; also, then don't look for the shortest unique abbreviations
+ (setq abbrev-length (+ abbrev-length 1)))))) ; else increase the length of the abbreviation; loop to while
+
+(defun days-of-week ()
+ "Find minimum abbreviation length of days of week."
+ (let ((current-line-list))
+ (find-file "Days_of_week.txt") ; open file or switch to buffer
+ (beginning-of-buffer) ; go to the top of the buffer
+ (dolist (current-line (split-string (buffer-string) "\n")) ; go line by line through buffer
+ (setq current-line-list (split-string current-line " ")) ; change each line into list of days of week
+ (cycle-days current-line-list))))
diff --git a/Task/Abbreviations-automatic/Fortran/abbreviations-automatic.f b/Task/Abbreviations-automatic/Fortran/abbreviations-automatic.f
new file mode 100644
index 0000000000..a53f211014
--- /dev/null
+++ b/Task/Abbreviations-automatic/Fortran/abbreviations-automatic.f
@@ -0,0 +1,113 @@
+!
+! Abbreviations, automatic
+! tested with Intel ifx (IFX) 2025.2.1 20250806 on Kubuntu 25.10
+! GNU Fortran (Ubuntu 15.2.0-4ubuntu4) 15.2.0 on Kubuntu 25.10
+! VSI Fortran x86-64 V8.6-001 on OpenVMS x86_64 V9.2-3
+! U.B., December 2025
+!==============================================================================
+
+program AbbrAuto
+ integer, parameter :: longestLine = 210 ! Longest input line
+ integer, parameter :: LongestDay = 30 ! Longest length of 1 day name
+ character (len=longestLine) :: Line
+ character (len=LongestDay) :: Days(7) ! 1 week
+
+ integer :: l, io_stat
+ logical :: OK
+
+ open (unit=10, file = 'days_of_week.txt', status='old', action='read', iostat=io_stat)
+ if (io_stat /= 0) then
+ print *, "Error opening file"
+ stop
+ end if
+
+
+ do ! Read all lines
+ read (10, '(A)', iostat=io_stat) Line
+ if (io_stat <0) exit ! Normal: EOF on input
+ if (io_stat >0) then ! Not Normal: Read error
+ print *, "Read error" ! has never been observed during testing.
+ exit
+ end if
+ call separateDays (Line, Days, OK)
+ if (OK) then ! 7 week days' name found
+ print '(I2, X, A)' , smallestAbreviation (Days), Line (:len_trim(Line))
+ else
+ print * ! Null string for empty or invalid line
+ endif
+
+ end do ! Read all lines
+
+ contains
+
+
+ ! =========================================================================================
+ ! Argument argLine contains space-separated list of (expected) 7 names of week days.
+ ! Separate day names into array argDays, OK is .false. if number of days is not exactly 7.
+ ! =========================================================================================
+ subroutine separateDays (argLine, argDays, OK)
+
+ character (len=longestLine), intent(in) :: argLine
+ character (len=LongestDay) , intent(out) :: argDays(7) ! 1 week
+ logical, intent(out) :: OK
+ integer :: ip1, ip2, nDays ! 2 Pointers into line, number of day names detected
+ integer :: l
+
+ ip1 = 1
+ nDays = 0
+
+ l = len_trim (argLine)
+ do while (ip1 .le. l) ! Loop untill entire line processed.
+ do while (ip1 .le. l .and. argLine (ip1:ip1) .eq. ' ') ! Skip space(s)
+ ip1 = ip1 + 1
+ end do
+ if (ip1 .le. l) then ! still inside Line?
+ ip2 = ip1
+ do while (ip2 .le. l .and. argLine (ip2:ip2) .ne. ' ') ! Find end of current word
+ ip2 = ip2 + 1
+ end do
+
+ ! Here found space or end of line: Word is complete
+ if (ip2 .gt. l) ip2 = l ! End reached
+ if (argLine (ip2:ip2) .eq. ' ') ip2 = ip2 - 1 ! Space found
+ if (ip2 .gt. ip1) then ! day name has at least 2 letters
+ nDays = nDays + 1
+ argDays (nDays) = ' '
+ argDays (nDays) = argLine (ip1:ip2)
+ endif !
+ ip1 = ip2 + 1 ! Prepare for next day search: set behind current word
+ endif
+ end do
+ OK = (nDays .eq. 7) ! Result is OK only if number of days is 7
+ end subroutine separateDays
+
+ ! =============================================================================
+ ! Find length of smallest abbreviation of 7 day names so that abbreviated name
+ ! is still unique.
+ ! =============================================================================
+ function smallestAbreviation (argDays) result (nUniq)
+ character (len=LongestDay) , intent(in) :: argDays(7) ! 1 week
+ integer :: nUniq
+ integer :: ii, jj
+ logical :: done
+ nUniq = 1
+ done = .false.
+ do while (.not. done)
+ done = .true.
+ daysLoop: do ii=1, 6
+ do jj=ii+1,7
+ if (argDays (ii)(:nUniq) .eq. argDays(jj)(:nUniq)) then
+ ! nUniq is too small for useful abbreviation of week days' name
+ nUniq = nUniq + 1
+ done = .false.
+ exit daysLoop ! go and try tith next larger nUniq
+ end if
+ end do
+ end do daysLoop
+ ! here: done is .true. if no two day names are identical in first 'nUuniq' characters
+ ! otherwise still the abbreviation is still too short
+ end do
+ end function smallestAbreviation
+
+
+end program AbbrAuto
diff --git a/Task/Abbreviations-automatic/Pluto/abbreviations-automatic.pluto b/Task/Abbreviations-automatic/Pluto/abbreviations-automatic.pluto
new file mode 100644
index 0000000000..3b32fef82e
--- /dev/null
+++ b/Task/Abbreviations-automatic/Pluto/abbreviations-automatic.pluto
@@ -0,0 +1,65 @@
+do -- Abbreviatiions automatic - find the minimum abbreviation lengths for days of the week
+ -- in various languages
+
+ require( "uchar" ) -- RC Pluto Unicode character library
+
+ -- returns the table of space delimited words in s
+ local function getWords( s : string ) : table
+ local t, cmds, w = s, {}, s
+ while t:contains( " " ) do
+ w, t = t:partition( " " )
+ if w != "" then
+ cmds[ # cmds + 1 ] = w
+ end
+ end
+ if t != "" then
+ cmds[ # cmds + 1 ] = t
+ end
+ return cmds
+ end
+
+ for dow in io.lines( "daysOfWeekNames.txt" ) do
+ local names = getWords( dow )
+ if # names == 0 then
+ io.write( "\n" )
+ elseif # names != 7 then
+ error( dow .. ": expected 7 names" )
+ elseif # names > 0 then
+ -- try abbreviation lengths up to the minimum word length
+ local maxLen, uName = -1, {}
+ for i, n in ipairs( names ) do
+ uName[ i ] = uchar.of( n )
+ local thisLen = uName[ i ]:len()
+ if thisLen > maxLen then
+ maxLen = thisLen
+ end
+ end
+ local found = false
+ for abLen = 1, maxLen do
+ local prefixes = {}
+ found = true
+ for nPos = 1, # names do
+ local subLen = if uName[ nPos ]:len() < abLen
+ then uName[ nPos ]:len()
+ else abLen
+ end
+ local ab = uName[ nPos ]:sub( 1, subLen )
+ if prefixes:contains( ab ) then
+ found = false
+ break
+ else
+ prefixes[ ab ] = ab
+ end
+ end
+ if found then
+ io.write( string.format( "%2d %s\n", abLen, dow ) )
+ break
+ end
+ end
+ if not found then
+ error( "No unique abbreviations for: " .. dow )
+ end
+ end
+ end
+
+end
diff --git a/Task/Abbreviations-automatic/Rebol/abbreviations-automatic.rebol b/Task/Abbreviations-automatic/Rebol/abbreviations-automatic.rebol
new file mode 100644
index 0000000000..7f2f40aacf
--- /dev/null
+++ b/Task/Abbreviations-automatic/Rebol/abbreviations-automatic.rebol
@@ -0,0 +1,30 @@
+Rebol [
+ title: "Rosetta code: Abbreviations, automatic"
+ file: %Abbreviations,_automatic.r3
+ url: https://rosettacode.org/wiki/Abbreviations,_automatic
+ needs: 3.0.0
+ note: "Based on Red language solution"
+]
+data: read/lines %abbrev.txt
+foreach line data [ ;; split data in lines at carriage return & line feed:
+ if empty? trim line [
+ print ""
+ continue ;; continues at head of loop
+ ]
+ arr: split line space ;; now split line in words ; accumulate in array / series
+ min: 1 ;; preset min length
+ m: make map! []
+ until [ ;; head is the first position of series
+ if head? arr [clear m] ;; define an empty map (key -value store)
+ abbr: copy/part first arr min ;; copy/part ~ leftstr of first word with length min
+ arr: either m/:abbr [ ;; abbreviation already exists ?
+ min: min + 1
+ head arr ;; reset series position to head
+ ][ ;; otherwise ....
+ m/:abbr: true ;; mark abreviation in map as existent
+ next arr ;; set series position to next word
+ ]
+ tail? arr ;; this is the until condition , end /tail of series reached ?
+ ]
+ print [min line] ;; print automatically reduces all words in block
+]
diff --git a/Task/Abbreviations-automatic/VBScript/abbreviations-automatic.vbs b/Task/Abbreviations-automatic/VBScript/abbreviations-automatic.vbs
new file mode 100644
index 0000000000..daaf4f3a31
--- /dev/null
+++ b/Task/Abbreviations-automatic/VBScript/abbreviations-automatic.vbs
@@ -0,0 +1,36 @@
+sub print(s) wscript.stdout.writeline s :end sub
+
+set d=createobject("Scripting.Dictionary")
+set fso=createobject("Scripting.Filesystemobject")
+
+const fn="weekdays_ansi.txt"
+sfn=WScript.ScriptFullName
+sfn= Left(sfn, InStrRev(sfn, "\"))
+set f=fso.opentextfile(sfn & fn,1)
+
+while not f.atendofstream
+ s=f.readline
+ if s=vbNullString then
+ print " "
+ else
+ a=split(trim(s)," ")
+ for abrlen=1 to 14
+ d.removeall
+ for wd=0 to 6
+ k=left(a(wd),abrlen)
+ if d.exists(k) then
+ exit for
+ else
+ d.add k,""
+ end if
+ next 'wd
+ if wd>6 then exit for
+ next 'abrlen
+ b=right(" " & abrlen,2)
+ for wd=0 to 6
+ b=b &" "& left(a(wd),abrlen)
+ next
+ print b
+ end if
+wend 'line
+f.close
diff --git a/Task/Abbreviations-easy/AWK/abbreviations-easy.awk b/Task/Abbreviations-easy/AWK/abbreviations-easy.awk
index 70a7c2cac5..4885af4516 100644
--- a/Task/Abbreviations-easy/AWK/abbreviations-easy.awk
+++ b/Task/Abbreviations-easy/AWK/abbreviations-easy.awk
@@ -10,28 +10,28 @@ split(" Add ALTer BAckup Bottom CAppend Change SCHANGE CInsert CLAst COMPre
" RIght LEft SAVE SET SHift SI SORT SOS STAck STATus TOP TRAnsfer Type Up" \
, CMD);
- for (k=1; k <= length(CMD); k++) {
- cmd[k] = CMD[k];
- sub(/[a-z]*$/,"",cmd[k]);
- # print "0: ",CMD[k],"\t",cmd[k];
- }
+ for (k=1; k <= length(CMD); k++) {
+ cmd[k] = CMD[k];
+ sub(/[a-z]*$/,"",cmd[k]);
+ # print "0: ",CMD[k],"\t",cmd[k];
+ }
}
function GET_ABBR(input) {
- for (k2=1; k2<=length(CMD); k2++) {
- if (index(toupper(CMD[k2]),input)==1) {
- if (index(input,toupper(cmd[k2]))==1) {
- return toupper(CMD[k2]);
- }
- }
- }
- return "*error*";
+ for (k2=1; k2<=length(CMD); k2++) {
+ if (index(toupper(CMD[k2]),input)==1) {
+ if (index(input,toupper(cmd[k2]))==1) {
+ return toupper(CMD[k2]);
+ }
+ }
+ }
+ return "*error*";
}
{
- R="";
- for (k1=1; k1 <= NF; k1++) {
- R=R" "GET_ABBR(toupper($k1))
- }
- print R;
+ R="";
+ for (k1=1; k1 <= NF; k1++) {
+ R=R" "GET_ABBR(toupper($k1))
+ }
+ print R;
}
diff --git a/Task/Abbreviations-easy/Ada/abbreviations-easy.adb b/Task/Abbreviations-easy/Ada/abbreviations-easy.adb
new file mode 100644
index 0000000000..17dbc7a2c5
--- /dev/null
+++ b/Task/Abbreviations-easy/Ada/abbreviations-easy.adb
@@ -0,0 +1,98 @@
+with Ada.Characters.Handling;
+with Ada.Containers.Indefinite_Vectors;
+with Ada.Strings.Fixed;
+with Ada.Strings.Maps.Constants;
+with Ada.Text_IO;
+
+procedure Abbreviations_Easy is
+
+ package Command_Vectors
+ is new Ada.Containers.Indefinite_Vectors (Index_Type => Positive,
+ Element_Type => String);
+ use Command_Vectors;
+
+ Commands : Vector;
+
+ procedure Append (Word_List : String) is
+ use Ada.Strings;
+ First : Positive := Word_List'First;
+ Last : Natural;
+ begin
+ loop
+ Fixed.Find_Token (Word_List,
+ Set => Maps.Constants.Letter_Set,
+ From => First,
+ Test => Inside,
+ First => First,
+ Last => Last);
+ exit when Last = 0;
+ Commands.Append (Word_List (First .. Last));
+ exit when Last = Word_List'Last;
+ First := Last + 1;
+ end loop;
+ end Append;
+
+ function Match (Word : String) return String is
+ use Ada.Strings;
+ use Ada.Characters.Handling;
+ Upper_Word : constant String := To_Upper (Word);
+ Prefix_First : Positive;
+ Prefix_Last : Natural;
+ begin
+ if Word = "" then
+ return "";
+ end if;
+
+ for Command of Commands loop
+ Fixed.Find_Token (Command, Maps.Constants.Upper_Set, Inside,
+ Prefix_First, Prefix_Last);
+ declare
+ Upper_Prefix : constant String := Command (Prefix_First .. Prefix_Last);
+ Upper_Command : constant String := To_Upper (Command);
+ Valid_Length : constant Boolean := Word'Length >= Upper_Prefix'Length;
+ Match_Length : constant Natural := Natural'Min (Word'Length,
+ Command'Length);
+ Valid_Match : constant Boolean
+ := Fixed.Head (Upper_Word, Upper_Word'Length)
+ = Fixed.Head (Upper_Command, Upper_Word'Length);
+ begin
+ if Valid_Length and Valid_Match then
+ return Upper_Command;
+ end if;
+ end;
+ end loop;
+ return "*error*";
+ end Match;
+
+ procedure Put_Match (To : String) is
+ use Ada.Text_IO;
+ M : constant String := Match (To);
+ begin
+ Put ("Match to '"); Put (To);
+ Put ("' is '"); Put (M);
+ Put_Line ("'");
+ end Put_Match;
+
+ procedure A (Item : String) renames Append;
+begin
+ A ("Add ALTer BAckup Bottom CAppend Change SCHANGE CInsert CLAst COMPress COpy");
+ A ("COUnt COVerlay CURsor DELete CDelete Down DUPlicate Xedit EXPand EXTract Find");
+ A ("NFind NFINDUp NFUp CFind FINdup FUp FOrward GET Help HEXType Input POWerinput");
+ A ("Join SPlit SPLTJOIN LOAD Locate CLocate LOWercase UPPercase LPrefix MACRO");
+ A ("MErge MODify MOve MSG Next Overlay PARSE PREServe PURge PUT PUTD Query QUIT");
+ A ("READ RECover REFRESH RENum REPeat Replace CReplace RESet RESTore RGTLEFT");
+ A ("RIght LEft SAVE SET SHift SI SORT SOS STAck STATus TOP TRAnsfer Type Up");
+
+ Put_Match ("riG");
+ Put_Match ("rePEAT");
+ Put_Match ("copies");
+ Put_Match ("put");
+ Put_Match ("mo");
+ Put_Match ("rest");
+ Put_Match ("types");
+ Put_Match ("fup.");
+ Put_Match ("6");
+ Put_Match ("poweRin");
+ Put_Match ("");
+ Put_Match ("o");
+end Abbreviations_Easy;
diff --git a/Task/Abbreviations-easy/AutoHotkey/abbreviations-easy.ahk b/Task/Abbreviations-easy/AutoHotkey/abbreviations-easy.ahk
index f188819fb2..103aee1a03 100644
--- a/Task/Abbreviations-easy/AutoHotkey/abbreviations-easy.ahk
+++ b/Task/Abbreviations-easy/AutoHotkey/abbreviations-easy.ahk
@@ -16,7 +16,7 @@ str := StrReplace(str,"`n")
comTable := StrSplit(RegExReplace(str, "\s+", " "), " ")
comTableCapsCount := []
for cmds in comTable
- comTableCapsCount.push(StrLen(RegExReplace(comTable[cmds], "[a-z]")))
+ comTableCapsCount.push(StrLen(RegExReplace(comTable[cmds], "[a-z]")))
; Take and process user input into an array of abbreviations
InputBox, abbrev, Command, Type in your command(s).`n If you have several commands`, leave spaces between them.
@@ -26,19 +26,19 @@ abbrev := StrSplit(RegExReplace(abbrev, "\s+", " "), " ")
; Double loop compares abbreviations to commands in command table
Loop % abbrev.MaxIndex() {
- count := A_Index
- found := false
- for cmds in comTable {
- command := SubStr(comTable[cmds], 1, StrLen(abbrev[count]))
- StringLower, lowerCaseCommand, command
- if (lowerCaseCommand = abbrev[count]) and (StrLen(abbrev[count]) >= comTableCapsCount[cmds]) {
- StringUpper, foundCmd, % comTable[cmds]
- found := true
- }
- }
- if (found)
- result .= " " foundCmd
- else
- result .= " *error*"
+ count := A_Index
+ found := false
+ for cmds in comTable {
+ command := SubStr(comTable[cmds], 1, StrLen(abbrev[count]))
+ StringLower, lowerCaseCommand, command
+ if (lowerCaseCommand = abbrev[count]) and (StrLen(abbrev[count]) >= comTableCapsCount[cmds]) {
+ StringUpper, foundCmd, % comTable[cmds]
+ found := true
+ }
+ }
+ if (found)
+ result .= " " foundCmd
+ else
+ result .= " *error*"
}
MsgBox % Trim(result)
diff --git a/Task/Abbreviations-easy/Euphoria/abbreviations-easy.eu b/Task/Abbreviations-easy/Euphoria/abbreviations-easy.eu
new file mode 100644
index 0000000000..a840e20d63
--- /dev/null
+++ b/Task/Abbreviations-easy/Euphoria/abbreviations-easy.eu
@@ -0,0 +1,35 @@
+include std/text.e -- for upper conversion
+include std/console.e -- for display
+include std/sequence.e
+
+sequence ct = """
+Add ALTer BAckup Bottom CAppend Change SCHANGE CInsert CLAst COMPress COpy
+COUnt COVerlay CURsor DELete CDelete Down DUPlicate Xedit EXPand EXTract Find
+NFind NFINDUp NFUp CFind FINdup FUp FOrward GET Help HEXType Input POWerinput
+Join SPlit SPLTJOIN LOAD Locate CLocate LOWercase UPPercase LPrefix MACRO
+MErge MODify MOve MSG Next Overlay PARSE PREServe PURge PUT PUTD Query QUIT
+READ RECover REFRESH RENum REPeat Replace CReplace RESet RESTore RGTLEFT
+RIght LEft SAVE SET SHift SI SORT SOS STAck STATus TOP TRAnsfer Type Up
+"""
+ct = upper(split(join(split(ct,"\n")," ")," "))
+
+object input = remove_all("\n",upper(remove_all("",split(gets(0)))))
+display(validate(input))
+
+-------------------------------
+function validate(object words)
+-------------------------------
+object results = repeat("*error*",length(words)) -- build an output list;
+integer x
+for i = 1 to length(words) do
+ words[i] = remove_all('\n',words[i]) -- final word in input line (may) have \n, get rid of it;
+ for j = 1 to length(ct) do
+ x = match(words[i],ct[j])
+ if x = 1 then
+ results[i] = ct[j] -- replace this slot in the output list with the "found" word;
+ exit -- and don't look further into the list;
+ end if
+ end for
+end for
+return flatten(join(results," ")) -- convert sequence of strings into one string, words separated by a single space;
+end function
diff --git a/Task/Abbreviations-easy/Fortran/abbreviations-easy.f b/Task/Abbreviations-easy/Fortran/abbreviations-easy.f
new file mode 100644
index 0000000000..45a7c90bce
--- /dev/null
+++ b/Task/Abbreviations-easy/Fortran/abbreviations-easy.f
@@ -0,0 +1,152 @@
+!
+! Abbreviations, easy
+! tested with Intel ifx (IFX) 2025.2.1 20250806 on Kubuntu 25.10
+! GNU Fortran (Ubuntu 15.2.0-4ubuntu4) 15.2.0 on Kubuntu 25.10
+! VSI Fortran x86-64 V8.6-001 on OpenVMS x86_64 V9.2-3
+! U.B., December 2025
+!==============================================================================
+program AbbrEasy
+
+ implicit none
+
+ integer, parameter :: lenCmd = 10
+ character (len=*), parameter :: cmdTable = &
+ 'Add ALTer BAckup Bottom CAppend Change SCHANGE CInsert CLAst COMPress COpy ' // &
+ 'COUnt COVerlay CURsor DELete CDelete Down DUPlicate Xedit EXPand EXTract Find ' // &
+ 'NFind NFINDUp NFUp CFind FINdup FUp FOrward GET Help HEXType Input POWerinput ' // &
+ 'Join SPlit SPLTJOIN LOAD Locate CLocate LOWercase UPPercase LPrefix MACRO ' // &
+ 'MErge MODify MOve MSG Next Overlay PARSE PREServe PURge PUT PUTD Query QUIT ' // &
+ 'READ RECover REFRESH RENum REPeat Replace CReplace RESet RESTore RGTLEFT ' // &
+ 'RIght LEft SAVE SET SHift SI SORT SOS STAck STATus TOP TRAnsfer Type Up'
+
+ character (len=*), parameter :: userCmds = &
+ ' riG rePEAT copies put mo rest types fup. 6 poweRin'
+
+ character (len=*), parameter :: invalid = '*error*'
+
+ character (len=len(cmdTable)) :: upcaseCmdTable
+ character (len=len(userCmds)) :: upcaseUserCmds
+ character (len=lenCmd) :: parsedCmd
+ character (len=lenCmd), allocatable :: allCmd (:), allUpcaseCmd(:)
+ character (len=lenCmd) inputCmd(10), upcaseInputCmd(10) ! 10 counted manually.
+
+ integer :: ip1, ip2
+ integer :: ii, l, la, nSpaces, nUP
+
+ ! Have a second command table, all in UPCASE , and count spaces so we get an idea how many
+ ! commands there are in total.
+ nSpaces = 0
+ do ii=1, len(cmdTable)
+ upcaseCmdTable (ii:ii) = toupper (cmdTable (ii:ii))
+ if (upcaseCmdTable (ii:ii) .eq. ' ') nSpaces = nSpaces + 1
+ end do
+
+ ! Also, have all user commands in UPCASE
+ do ii=1, len(userCmds)
+ upcaseUserCmds (ii:ii) = toupper (userCmds (ii:ii))
+ end do
+
+ ! make space for the array with all commands bioth upper and lower case.
+ allocate (allCmd (nSpaces+1)) ! might be more than needed bc superfluous spaces
+ allocate (allUpcaseCmd (nSpaces+1))
+
+ ! Prepare lists of allowed commands and input commands
+ call tokenize (cmdTable, upcaseCmdTable, allCmd,allUpcaseCmd)
+ call tokenize (userCmds, upcaseUserCmds, inputCmd, upcaseInputCmd)
+
+ ! As first output line, print user input
+ write (*, '(10(A10,x))') (inputCmd(ip1), ip1=1, size(inputCmd))
+ ! Parse all user input commands
+ do ip1 = 1, size(inputCmd)
+ l = len_trim (inputCmd(ip1))
+ parsedCmd = invalid
+ do ip2 = 1, size(allCmd)
+ la =len_trim(allCmd(ip2))
+ if (la .ge. l) then ! input is possible abbreviation of this command
+ ! Case blind comparison
+ if (allUpcaseCmd(ip2)(:l) .eq. upcaseInputCmd (ip1) (:l)) then
+ ! at least this input cmd is a short form of this full command.
+ ! But is it valid?
+ NUP = 0 ! Count number of starting UPCASE letters of command
+ do ii=1, la
+ if (allCmd (ip2)(ii:ii) .eq. allUpcaseCmd (ip2)(ii:ii)) then
+ NUP = NUP + 1
+ else
+ exit ! found number of upcase characters, quit search.
+ end if
+ end do
+ if (NUP .gt. l) then
+ cycle ! input is shorter than required minimum length, try next command
+ endif
+ else
+ cycle ! input does not match command
+ endif
+ ! Here we know that input an abbreviation of command,
+ ! and that it is not too short
+ parsedCmd = allUpcaseCmd (ip2) ! We have a result
+ exit ! no need to check input against following commands
+ else
+ ! input is longer than this command, nothing to do.
+ end if
+ end do
+ ! here we found the valid command, or the parsed value is still
+ write (*, '(A10,X)', advance='no') parsedCmd
+ end do
+ write (*,*) ! Terminate output line.
+
+contains
+
+ ! ======================================================================================
+ ! Divide a string of words separated by blanks into an array of the words without blanks
+ ! ======================================================================================
+ subroutine tokenize (tokenString, upCaseString, retList, upcaseRetList )
+
+ character (len=*), intent(in) :: tokenString, upcaseString ! input "as is" and "upcase"
+ character (len=lencmd), intent(inout) :: retList(*), upcaseRetList(*) ! Result "as is" and "Upcase"
+ integer :: ip1, ip2
+ integer :: nTokens
+ ip1 = 1
+ nTokens = 0
+
+ ! Divide single string to a list of words without spaces.
+ l = len_trim (tokenString)
+ do while (ip1 .le. l)
+ do while (ip1 .le. l .and. tokenString (ip1:ip1) .eq. ' ') ! Skip space(s)
+ ip1 = ip1 + 1
+ end do
+ if (ip1 .le. l) then ! still inside Line?
+ ip2 = ip1
+ do while (ip2 .le. l .and. tokenString (ip2:ip2) .ne. ' ') ! Find end of current word
+ ip2 = ip2 + 1
+ end do
+ if (ip2 .gt. l) ip2 = l ! End reached
+ nTokens = nTokens + 1
+! print *, 'Command = ', tokenString (ip1:ip2)
+ retList (nTokens) = tokenString (ip1:ip2)
+ upcaseRetList (nTokens) = upcaseString (ip1:ip2)
+ ip1 = ip2 + 1
+ endif
+ end do
+
+ end subroutine tokenize
+
+ ! =========================================================
+ ! Convert a character c to UPPER CASE, if its in lower case.
+ ! =========================================================
+
+ function toupper (c) result (U)
+ character, intent(in) :: c ! input
+ character :: U ! output
+ integer :: ix ! Helper: index of c in alphabet
+
+ Character(26), Parameter :: cap = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
+ Character(26), Parameter :: low = 'abcdefghijklmnopqrstuvwxyz'
+
+ ix = index (low, c) ! find c in lower case alphabet
+ if (ix .gt. 0) then ! c found: it is in lower case
+ U = cap (ix:ix) ! ...and needs conversion
+ else ! c not found, so is already in upper case,
+ U = c ! ...or it is not a letter. Just copy to result.
+ endif
+ end function toupper
+end program AbbrEasy
diff --git a/Task/Abbreviations-easy/JavaScript/abbreviations-easy.js b/Task/Abbreviations-easy/JavaScript/abbreviations-easy.js
index c277c13403..82bdef3953 100644
--- a/Task/Abbreviations-easy/JavaScript/abbreviations-easy.js
+++ b/Task/Abbreviations-easy/JavaScript/abbreviations-easy.js
@@ -15,7 +15,7 @@ console.log(input.length==0?null:input.trim().split(/\s+/)
(s=>abr.filter(
a=>(new RegExp('^'+escapeRegex(s),'i'))
.test(a)&&s.length>=a.match(/^[A-Z]+/)[0].length
- )[0])
- )
+ )[0])
+ )
.map(_=>typeof _=="undefined"?"*error*":_).join(' ')
- )
+ )
diff --git a/Task/Abbreviations-easy/Lua/abbreviations-easy.lua b/Task/Abbreviations-easy/Lua/abbreviations-easy.lua
index 2ad8bedd27..4fb6ff8fab 100644
--- a/Task/Abbreviations-easy/Lua/abbreviations-easy.lua
+++ b/Task/Abbreviations-easy/Lua/abbreviations-easy.lua
@@ -44,10 +44,10 @@ local function is_valid(cmd,abbrev)
-- test if any lowercase in "cmd"
if false then do -- NOTE!: requirement spec error .. put not equal PUT
- local lowcase = string.match(cmd,"%l+")
- if lowcase == nil then return -2 end
- if #lowcase < 1 then return -3 end
- end
+ local lowcase = string.match(cmd,"%l+")
+ if lowcase == nil then return -2 end
+ if #lowcase < 1 then return -3 end
+ end
end
-- test if abbrev is too long
@@ -75,13 +75,13 @@ local function start()
for i = 1,#t2 do
good = 0
for j = 1,#t1 do
- local abbrev = t2[i]
- local cmd = t1[j]
- good = is_valid(cmd,abbrev)
- if good==1 then do
- result[#result+1] = t1[j]:upper()
- break end
- end --if
+ local abbrev = t2[i]
+ local cmd = t1[j]
+ good = is_valid(cmd,abbrev)
+ if good==1 then do
+ result[#result+1] = t1[j]:upper()
+ break end
+ end --if
end --for j
if good < 1 then result[#result+1] = "*error*" end
end --for i
diff --git a/Task/Abbreviations-easy/MATLAB/abbreviations-easy.m b/Task/Abbreviations-easy/MATLAB/abbreviations-easy.m
index 5e99ffc691..d080f05416 100644
--- a/Task/Abbreviations-easy/MATLAB/abbreviations-easy.m
+++ b/Task/Abbreviations-easy/MATLAB/abbreviations-easy.m
@@ -8,22 +8,22 @@ CMD=strsplit(['Add ALTer BAckup Bottom CAppend Change SCHANGE CInsert CLAst C
' READ RECover REFRESH RENum REPeat Replace CReplace RESet RESTore RGTLEFT' ...
' RIght LEft SAVE SET SHift SI SORT SOS STAck STATus TOP TRAnsfer Type Up' ],' ');
-for k=1:length(CMD)
- cmd{k} = CMD{k}(CMD{k}<'a');
- CMD{k} = upper(CMD{k});
+for k=1:length(CMD)
+ cmd{k} = CMD{k}(CMD{k}<'a');
+ CMD{k} = upper(CMD{k});
end
ilist = strsplit(input,' ');
R = '';
for k=1:length(ilist)
- input = upper(ilist{k});
+ input = upper(ilist{k});
- ix = find(strncmp(CMD, input, length(input)));
- result= '*error*';
- for k = ix(:)',
- if strncmp(input, cmd{k}, length(cmd{k}));
- result = CMD{k};
- end
- end
- R = [R,' ',result];
+ ix = find(strncmp(CMD, input, length(input)));
+ result= '*error*';
+ for k = ix(:)',
+ if strncmp(input, cmd{k}, length(cmd{k}));
+ result = CMD{k};
+ end
+ end
+ R = [R,' ',result];
end
diff --git a/Task/Abbreviations-easy/Pluto/abbreviations-easy.pluto b/Task/Abbreviations-easy/Pluto/abbreviations-easy.pluto
new file mode 100644
index 0000000000..9b177460f5
--- /dev/null
+++ b/Task/Abbreviations-easy/Pluto/abbreviations-easy.pluto
@@ -0,0 +1,79 @@
+do -- Abbreviatiions Easy - expand command name abbreviations
+
+ -- returns the table of space delimited words in s
+ local function getWords( s : string ) : table
+ local t, cmds, w = s, {}, s
+ while t:contains( " " ) do
+ w, t = t:partition( " " )
+ if w != "" then
+ cmds[ # cmds + 1 ] = w
+ end
+ end
+ if t != "" then
+ cmds[ # cmds + 1 ] = t
+ end
+ return cmds
+ end
+
+ local commandStrings = "Add ALTer BAckup Bottom CAppend Change SCHANGE CInsert CLAst COMPress COpy "
+ .. "COUnt COVerlay CURsor DELete CDelete Down DUPlicate Xedit EXPand EXTract Find "
+ .. "NFind NFINDUp NFUp CFind FINdup FUp FOrward GET Help HEXType Input POWerinput "
+ .. "Join SPlit SPLTJOIN LOAD Locate CLocate LOWercase UPPercase LPrefix MACRO "
+ .. "MErge MODify MOve MSG Next Overlay PARSE PREServe PURge PUT PUTD Query QUIT "
+ .. "READ RECover REFRESH RENum REPeat Replace CReplace RESet RESTore RGTLEFT "
+ .. "RIght LEft SAVE SET SHift SI SORT SOS STAck STATus TOP TRAnsfer Type Up"
+
+ local function expandEasyAbbreviations( cmds : string, input : string ) : table
+ local cmdTable, inputTable, outputTable = getWords( cmds ), getWords( input ), {}
+
+ local function isCommand( cmd : string, word : string ) : boolean
+ local result, uCmd, uWord = false, cmd:upper(), word:upper()
+ if # cmd >= # word then -- word is not longer than the command
+ if uCmd == uWord then -- the word is the command
+ result = true
+ else -- word is shorter than the command
+ local ab = cmd:gsub( "%l", "" ) -- remove lowercase
+ if # ab <= # word then -- the minimum abbreviation isn't longer than the word
+ result = uWord == uCmd:sub( 1, # word )
+ end
+ end
+ end
+ return result
+ end
+
+ for i = 1, # inputTable do
+ local w, u = inputTable[ i ], "*error*"
+ for c = 1, # cmdTable do
+ if isCommand( cmdTable[ c ], w ) then
+ u = cmdTable[ c ]:upper()
+ break
+ end
+ end
+ outputTable[ # outputTable + 1 ] = u
+ end
+ return { inputTable, outputTable }
+ end
+
+ local function printExpansion( expansion : table )
+ local fmt, input, output = {}, expansion[ 1 ], expansion[ 2 ]
+ for i, v in ipairs( output ) do
+ fmt[ i ] = " %" .. # v .. "s"
+ end
+ io.write( "Input: " )
+ for i, v in ipairs( input ) do
+ io.write( string.format( fmt[ i ], v ) )
+ end
+ io.write( "\nOutput:" )
+ for i, v in ipairs( output ) do
+ io.write( string.format( fmt[ i ], v ) )
+ end
+ io.write( "\n" )
+ end
+
+ printExpansion( expandEasyAbbreviations( commandStrings
+ , ( "riG rePEAT copies put mo rest "
+ .. "types fup. 6 poweRin"
+ )
+ )
+ )
+end
diff --git a/Task/Abbreviations-easy/PowerShell/abbreviations-easy.ps1 b/Task/Abbreviations-easy/PowerShell/abbreviations-easy.ps1
new file mode 100644
index 0000000000..ad178249f3
--- /dev/null
+++ b/Task/Abbreviations-easy/PowerShell/abbreviations-easy.ps1
@@ -0,0 +1,44 @@
+<# Start with a string of the commands #>
+$cmdTableStr =
+"Add ALTer BAckup Bottom CAppend Change SCHANGE CInsert CLAst COMPress COpy
+ COUnt COVerlay CURsor DELete CDelete Down DUPlicate Xedit EXPand EXTract Find
+ NFind NFINDUp NFUp CFind FINdup FUp FOrward GET Help HEXType Input POWerinput
+ Join SPlit SPLTJOIN LOAD Locate CLocate LOWercase UPPercase LPrefix MACRO
+ MErge MODify MOve MSG Next Overlay PARSE PREServe PURge PUT PUTD Query QUIT
+ READ RECover REFRESH RENum REPeat Replace CReplace RESet RESTore RGTLEFT
+ RIght LEft SAVE SET SHift SI SORT SOS STAck STATus TOP TRAnsfer Type Up"
+<# String of inputs #>
+$userWordStr = "riG rePEAT copies put mo rest types fup. 6 poweRin"
+
+$outputStr = $null # Set this string to null only so all variables are intialized
+
+$cmdTabArray = @() # Arrays for the commands and the inputs
+$userWordArray = @()
+
+<# Split the strings into arrays using a space as the delimiter.
+ This also removes "blank" entries, which fits the requirement
+ "A blank input (or a null input) should return a null string." #>
+$cmdTabArray = $cmdTableStr.Split(" ", [System.StringSplitOptions]::RemoveEmptyEntries)
+$userWordArray = $userWordStr.Split(" ", [System.StringSplitOptions]::RemoveEmptyEntries)
+
+<# Begins a loop to iterate through the inputs #>
+foreach($word in $userWordArray)
+{
+ $match = $false # Variable set to false so that if a match is never found, the "*error*" string can be appended
+ foreach($cmd in $cmdTabArray)
+ {
+ <# This test: 1) ensures inputs match the leading characters of the command
+ 2) are abbreviations of the command
+ 3) the abbreviations is at least the number of capital characters in the command #>
+ if($cmd -like "$word*" -and ($word.Length -ge ($cmd -creplace '[a-z]').Length))
+ {
+ $outputStr += $cmd.ToUpper() + " " # Adds the command in all caps to the output string
+ $match = $true # Sets the variable so that "*error*" is not appended
+ break # Break keep the loop from continuing and wasting time once a match was found
+ }
+ }
+ if($match -eq $false){ $outputStr += "*error* " } # Appends error if no match was found
+}
+# Below lines display the input and output
+"User text: " + $userWordStr
+"Full text: " + $outputStr
diff --git a/Task/Abbreviations-easy/Rebol/abbreviations-easy.rebol b/Task/Abbreviations-easy/Rebol/abbreviations-easy.rebol
new file mode 100644
index 0000000000..78065be75f
--- /dev/null
+++ b/Task/Abbreviations-easy/Rebol/abbreviations-easy.rebol
@@ -0,0 +1,55 @@
+Rebol [
+ title: "Rosetta code: Abbreviations, easy"
+ file: %Abbreviations,_easy.r3
+ url: https://rosettacode.org/wiki/Abbreviations,_easy
+]
+
+get-full-name: function [
+ "Validate abbreviated commands against a command table"
+ word [string! char!]
+ commands [block!]
+][
+ word: to string! word
+ foreach cmd commands [
+ ;; count required uppercase prefix length
+ prefix-end: 0
+ foreach c cmd [
+ if c > #"Z" [break]
+ ++ prefix-end
+ ]
+ prefix: copy/part cmd prefix-end
+ if all [
+ parse word [prefix to end] ;; starts with required prefix
+ parse cmd [word to end] ;; is not longer than command
+ ][
+ return uppercase copy cmd
+ ]
+ ]
+ "*error*"
+]
+
+split-commands: function/with [commands [string!]][
+ parse commands [
+ any delimit
+ collect any [keep some chars any delimit]
+ ]
+][
+ delimit: charset " ^-^/"
+ chars: complement delimit
+]
+
+commands: split-commands {
+ Add ALTer BAckup Bottom CAppend Change SCHANGE CInsert CLAst COMPress COpy
+ COUnt COVerlay CURsor DELete CDelete Down DUPlicate Xedit EXPand EXTract Find
+ NFind NFINDUp NFUp CFind FINdup FUp FOrward GET Help HEXType Input POWerinput
+ Join SPlit SPLTJOIN LOAD Locate CLocate LOWercase UPPercase LPrefix MACRO
+ MErge MODify MOve MSG Next Overlay PARSE PREServe PURge PUT PUTD Query QUIT
+ READ RECover REFRESH RENum REPeat Replace CReplace RESet RESTore RGTLEFT
+ RIght LEft SAVE SET SHift SI SORT SOS STAck STATus TOP TRAnsfer Type Up}
+
+inputs: split-commands {riG rePEAT copies put mo rest types fup. 6 poweRin}
+
+foreach cmd inputs [
+ full: get-full-name cmd commands
+ print [pad cmd 10 '-> full]
+]
diff --git a/Task/Abbreviations-easy/Vedit-macro-language/abbreviations-easy.vedit b/Task/Abbreviations-easy/Vedit-macro-language/abbreviations-easy.vedit
index 91e698f43c..540839e16e 100644
--- a/Task/Abbreviations-easy/Vedit-macro-language/abbreviations-easy.vedit
+++ b/Task/Abbreviations-easy/Vedit-macro-language/abbreviations-easy.vedit
@@ -16,18 +16,18 @@ Ins_Text("riG rePEAT copies put mo rest types fup. 6 poweRin ")
BOF
// Main program
-#20 = Reg_Free() // Text register for the word to be converted
+#20 = Reg_Free() // Text register for the word to be converted
Repeat(ALL) {
- Buf_Switch(#11) // Buffer for example input
- Search("|!|X", ERRBREAK) // Find next non-space character
- #30 = Cur_Pos // #30 = begin of a word
- Search("|X", NOERR+NORESTORE) // Find whitespace (end of the word)
- Reg_Copy_Block(#20, #30, Cur_Pos) // Get the word to text register #20
- Call("acronym_to_word") // Convert acronym to full word
- Reg_Type(#20) // Display the full word
- Type_Char(' ') // Display a space character
+ Buf_Switch(#11) // Buffer for example input
+ Search("|!|X", ERRBREAK) // Find next non-space character
+ #30 = Cur_Pos // #30 = begin of a word
+ Search("|X", NOERR+NORESTORE) // Find whitespace (end of the word)
+ Reg_Copy_Block(#20, #30, Cur_Pos) // Get the word to text register #20
+ Call("acronym_to_word") // Convert acronym to full word
+ Reg_Type(#20) // Display the full word
+ Type_Char(' ') // Display a space character
}
-Buf_Switch(#10) Buf_Quit(OK) // Clean-up
+Buf_Switch(#10) Buf_Quit(OK) // Clean-up
Buf_Switch(#11) Buf_Quit(OK)
Reg_Empty(#20)
Return
@@ -37,29 +37,29 @@ Return
// Return: @(#20) = the full word
//
:acronym_to_word:
-if (Reg_Size(#20) == 0) { // If zero length input,
- return // return zero length string
+if (Reg_Size(#20) == 0) { // If zero length input,
+ return // return zero length string
}
-Buf_Switch(#10) // Switch to command table
+Buf_Switch(#10) // Switch to command table
BOF
While (!At_EOF) {
- if (Search("|S|@(#20)", NOERR)) { // Find (the first part of) the word
- Char // Skip the separator
- #31 = Cur_Pos // #31 = Begin of the acronym
- Char(Reg_Size(#20)) // Check if the acronym is log enough
- if (Cur_Char < 'A' || Cur_Char > 'Z') { // Not a capital letter, verified
- Search("|X") // Find the end of the word
- Reg_Copy_Block(#20, #31, Cur_Pos) // Get the word into text register #20
- Buf_Switch(Buf_Free) // Convert to upper case using tmp buffer
- Reg_Ins(#20)
- Case_Upper_Block(0, Cur_Pos)
- Reg_Copy_Block(#20, 0, Cur_Pos)
- Buf_Quit(OK)
- break // Word found, exit loop
- }
- } else { // Not found
- Reg_Set(#20, "*error*")
- break
+ if (Search("|S|@(#20)", NOERR)) { // Find (the first part of) the word
+ Char // Skip the separator
+ #31 = Cur_Pos // #31 = Begin of the acronym
+ Char(Reg_Size(#20)) // Check if the acronym is log enough
+ if (Cur_Char < 'A' || Cur_Char > 'Z') { // Not a capital letter, verified
+ Search("|X") // Find the end of the word
+ Reg_Copy_Block(#20, #31, Cur_Pos) // Get the word into text register #20
+ Buf_Switch(Buf_Free) // Convert to upper case using tmp buffer
+ Reg_Ins(#20)
+ Case_Upper_Block(0, Cur_Pos)
+ Reg_Copy_Block(#20, 0, Cur_Pos)
+ Buf_Quit(OK)
+ break // Word found, exit loop
+ }
+ } else { // Not found
+ Reg_Set(#20, "*error*")
+ break
}
}
Return
diff --git a/Task/Abbreviations-easy/Zkl/abbreviations-easy.zkl b/Task/Abbreviations-easy/Zkl/abbreviations-easy.zkl
index 83e3a2f98d..3ded775160 100644
--- a/Task/Abbreviations-easy/Zkl/abbreviations-easy.zkl
+++ b/Task/Abbreviations-easy/Zkl/abbreviations-easy.zkl
@@ -1,4 +1,4 @@
-commands:=Data(0,String, // "Add\0ALTer\0..."
+commands:=Data(0,String, // "Add\0ALTer\0..."
#<<<
"Add ALTer BAckup Bottom CAppend Change SCHANGE CInsert CLAst COMPress COpy
COUnt COVerlay CURsor DELete CDelete Down DUPlicate Xedit EXPand EXTract Find
@@ -11,14 +11,14 @@ commands:=Data(0,String, // "Add\0ALTer\0..."
#<<<
testText:=" riG rePEAT copies put mo rest types "
- "fup. 6 poweRin";
+ "fup. 6 poweRin";
testText.split().apply('wrap(word){
sz,w := word.len(),word + "*";
- foreach c in (commands){ // rather inelegant but gotta ignore case
+ foreach c in (commands){ // rather inelegant but gotta ignore case
// check for length requirement and, if there, verify
if(c.matches(w) and sz>=(c-"abcdefghijklmnopqrstuvwxyz").len())
- return(c.toUpper());
+ return(c.toUpper());
}
"*error*"
.concat(" ").println();
diff --git a/Task/Abbreviations-simple/Ada/abbreviations-simple.adb b/Task/Abbreviations-simple/Ada/abbreviations-simple.adb
new file mode 100644
index 0000000000..89413455d5
--- /dev/null
+++ b/Task/Abbreviations-simple/Ada/abbreviations-simple.adb
@@ -0,0 +1,130 @@
+with Ada.Characters.Handling;
+with Ada.Containers.Vectors;
+with Ada.Strings.Fixed;
+with Ada.Strings.Maps.Constants;
+with Ada.Strings.Unbounded;
+with Ada.Text_IO;
+
+procedure Abbreviations_Simple is
+
+ use Ada.Strings.Unbounded;
+ subtype Ustring is Unbounded_String;
+
+ type Word_Entry is record
+ Word : Ustring;
+ Min : Natural;
+ end record;
+
+ package Command_Vectors
+ is new Ada.Containers.Vectors (Index_Type => Positive,
+ Element_Type => Word_Entry);
+
+ Commands : Command_Vectors.Vector;
+ Last_Word : Ustring;
+ Last_Was_Word : Boolean := False;
+
+ procedure Append (Word_List : String) is
+ use Ada.Strings;
+
+ function Is_Word (Item : String) return Boolean
+ is (Fixed.Count (Item, Maps.Constants.Letter_Set) /= 0);
+
+ procedure Process (Token : String) is
+ begin
+ if Is_Word (Token) then
+ if Last_Was_Word then
+ Commands.Append ((Word => Last_Word,
+ Min => Length (Last_Word)));
+ end if;
+ Last_Word := To_Unbounded_String (Token);
+ Last_Was_Word := True;
+
+ else -- Token is expected to be decimal
+ Commands.Append ((Word => Last_Word,
+ Min => Natural'Value (Token)));
+ Last_Was_Word := False;
+ end if;
+ end Process;
+
+ Token_First : Positive := Word_List'First;
+ Token_Last : Natural;
+ begin
+ while Token_First in Word_List'Range loop
+
+ Fixed.Find_Token (Word_List, Maps.Constants.Alphanumeric_Set,
+ Token_First, Inside,
+ Token_First, Token_Last);
+ exit when Token_Last = 0;
+
+ Process (Word_List (Token_First .. Token_Last));
+
+ Token_First := Token_Last + 1;
+ end loop;
+ end Append;
+
+ function Match (Word : String) return String is
+ use Ada.Characters.Handling;
+ use Ada.Strings.Fixed;
+ Result : Ustring := To_Unbounded_String ("*error*");
+ Min : Natural := 0;
+ Upper_Word : constant String := To_Upper (Word);
+ begin
+ if Upper_Word = "" then
+ return "";
+ end if;
+
+ for Candidate of Commands loop
+ declare
+ Upper_Cand : constant String := To_Upper (To_String (Candidate.Word));
+ Length : constant Natural := Natural'Max (Candidate.Min,
+ Upper_Word'Length);
+ Upper_Abbrev_Cand : constant String := Head (Upper_Cand, Length);
+ Upper_Abbrev_Word : constant String := Head (Upper_Word, Length);
+ begin
+ if Upper_Word = Upper_Cand
+ and then Upper_Word'Length > Min
+ then
+ Result := To_Unbounded_String (Upper_Cand);
+ Min := Upper_Word'Length;
+ elsif Upper_Abbrev_Word = Upper_Abbrev_Cand
+ and then Upper_Abbrev_Word'Length > Min
+ then
+ Result := To_Unbounded_String (Upper_Cand);
+ Min := Upper_Abbrev_Word'Length;
+ end if;
+ end;
+ end loop;
+ return To_String (Result);
+ end Match;
+
+ procedure Put_Match (To : String) is
+ use Ada.Text_IO;
+ begin
+ Put ("Match to '"); Put (To);
+ Put ("' is '"); Put (Match (To));
+ Put_Line ("'");
+ end Put_Match;
+
+ procedure A (Item : String) renames Append;
+begin
+ A ("add 1 alter 3 backup 2 bottom 1 Cappend 2 change 1 Schange Cinsert 2 Clast 3");
+ A ("compress 4 copy 2 count 3 Coverlay 3 cursor 3 delete 3 Cdelete 2 down 1 duplicate");
+ A ("3 xEdit 1 expand 3 extract 3 find 1 Nfind 2 Nfindup 6 NfUP 3 Cfind 2 findUP 3 fUP 2");
+ A ("forward 2 get help 1 hexType 4 input 1 powerInput 3 join 1 split 2 spltJOIN load");
+ A ("locate 1 Clocate 2 lowerCase 3 upperCase 3 Lprefix 2 macro merge 2 modify 3 move 2");
+ A ("msg next 1 overlay 1 parse preserve 4 purge 3 put putD query 1 quit read recover 3");
+ A ("refresh renum 3 repeat 3 replace 1 Creplace 2 reset 3 restore 4 rgtLEFT right 2 left");
+ A ("2 save set shift 2 si sort sos stack 3 status 4 top transfer 3 type 1 up 1");
+
+ Put_Match ("riG");
+ Put_Match ("rePEAT");
+ Put_Match ("copies");
+ Put_Match ("put");
+ Put_Match ("mo");
+ Put_Match ("rest");
+ Put_Match ("types");
+ Put_Match ("fup.");
+ Put_Match ("6");
+ Put_Match ("poweRin");
+ Put_Match ("");
+end Abbreviations_Simple;
diff --git a/Task/Abbreviations-simple/D/abbreviations-simple.d b/Task/Abbreviations-simple/D/abbreviations-simple.d
index b071380f6d..7d3702b122 100644
--- a/Task/Abbreviations-simple/D/abbreviations-simple.d
+++ b/Task/Abbreviations-simple/D/abbreviations-simple.d
@@ -1,36 +1,36 @@
class Abbreviations
{
- import std.array: split, join;
- import std.uni:toUpper;
+ import std.array: split, join;
+ import std.uni:toUpper;
- string[string] replaces;
-
- this(string table)
- {
- import std.ascii;
- import std.conv:parse;
+ string[string] replaces;
- string saved;
- auto add = (string word){ if(word.length) replaces[word] = word; };
+ this(string table)
+ {
+ import std.ascii;
+ import std.conv:parse;
- foreach(word; table.toUpper.split)
- if(isDigit(word[0]))
- {
- for(int length=parse!int(word); length<=saved.length; ++length)
- replaces[saved[0..length]] = saved;
- } else
- {
- add(saved);
- saved = word;
- }
- add(saved);
- }
+ string saved;
+ auto add = (string word){ if(word.length) replaces[word] = word; };
- string expand(string input) // pre-filled hashtable is used
- {
- import std.algorithm: map;
- return input.toUpper.split.map!(word => word in replaces ? replaces[word] : "*error*").join(" ");
- }
+ foreach(word; table.toUpper.split)
+ if(isDigit(word[0]))
+ {
+ for(int length=parse!int(word); length<=saved.length; ++length)
+ replaces[saved[0..length]] = saved;
+ } else
+ {
+ add(saved);
+ saved = word;
+ }
+ add(saved);
+ }
+
+ string expand(string input) // pre-filled hashtable is used
+ {
+ import std.algorithm: map;
+ return input.toUpper.split.map!(word => word in replaces ? replaces[word] : "*error*").join(" ");
+ }
}
string table = "
@@ -48,16 +48,16 @@ string expected = "RIGHT REPEAT *error* PUT MOVE RESTORE *error* *error* *error*
unittest // 'dmd -unittest ...' to activate it
{
- auto expander = new Abbreviations(table);
- assert(expander.expand(input) == expected);
- assert(expander.expand("") == "");
- assert(expander.expand("addadd") == "*error*");
+ auto expander = new Abbreviations(table);
+ assert(expander.expand(input) == expected);
+ assert(expander.expand("") == "");
+ assert(expander.expand("addadd") == "*error*");
}
void main()
{
- import std.stdio:writeln;
+ import std.stdio:writeln;
- writeln("Input : ", input);
- writeln("Output: ", new Abbreviations(table).expand(input));
+ writeln("Input : ", input);
+ writeln("Output: ", new Abbreviations(table).expand(input));
}
diff --git a/Task/Abbreviations-simple/Fortran/abbreviations-simple.f b/Task/Abbreviations-simple/Fortran/abbreviations-simple.f
new file mode 100644
index 0000000000..996e18f840
--- /dev/null
+++ b/Task/Abbreviations-simple/Fortran/abbreviations-simple.f
@@ -0,0 +1,184 @@
+!
+! Abbreviations, simple
+! tested with Intel ifx (IFX) 2025.2.1 20250806 on Kubuntu 25.10
+! GNU Fortran (Ubuntu 15.2.0-4ubuntu4) 15.2.0 on Kubuntu 25.10
+! VSI Fortran does not/not yet compile this code.
+! U.B., December 2025
+!==============================================================================
+program AbbrSimple
+
+ implicit none
+
+ integer, parameter :: lenCmd = 10
+ character (len=*), parameter :: cmdTable = &
+ 'add 1 alter 3 backup 2 bottom 1 Cappend 2 change 1 Schange Cinsert 2 Clast 3 '&
+ 'compress 4 copy 2 count 3 Coverlay 3 cursor 3 delete 3 Cdelete 2 down 1 duplicate '&
+ '3 xEdit 1 expand 3 extract 3 find 1 Nfind 2 Nfindup 6 NfUP 3 Cfind 2 findUP 3 fUP 2 '&
+ 'forward 2 get help 1 hexType 4 input 1 powerInput 3 join 1 split 2 spltJOIN load '&
+ 'locate 1 Clocate 2 lowerCase 3 upperCase 3 Lprefix 2 macro merge 2 modify 3 move 2 '&
+ 'msg next 1 overlay 1 parse preserve 4 purge 3 put putD query 1 quit read recover 3 '&
+ 'refresh renum 3 repeat 3 replace 1 Creplace 2 reset 3 restore 4 rgtLEFT right 2 left '&
+ '2 save set shift 2 si sort sos stack 3 status 4 top transfer 3 type 1 up 1 '
+
+
+ character (len=*), parameter :: userCmds = &
+ ' riG rePEAT copies put mo rest types fup. 6 poweRin'
+
+ character (len=*), parameter :: invalid = '*error*'
+
+ character (len=len(cmdTable)) :: upcaseCmdTable
+ character (len=len(userCmds)) :: upcaseUserCmds
+ character (len=lenCmd) :: parsedCmd
+ character (len=lenCmd), allocatable :: allCmd (:), allUpcaseCmd(:)
+ integer, allocatable :: minLength (:)
+
+ character (len=lenCmd) inputCmd(10), upcaseInputCmd(10) ! 10 counted manually.
+
+ integer :: ip1, ip2
+ integer :: ii, l, la, nSpaces
+
+ ! Prepare command table to UPPER CASE for case-blind compare
+ ! count spaces so we get an idea how many commands there are in total.
+
+ nSpaces = 0
+ do ii=1, len(cmdTable)
+ upcaseCmdTable (ii:ii) = toupper (cmdTable (ii:ii))
+ if (upcaseCmdTable (ii:ii) .eq. ' ') nSpaces = nSpaces + 1
+ end do
+
+ ! Also, have all user commands in UPCASE
+ do ii=1, len(userCmds)
+ upcaseUserCmds (ii:ii) = toupper (userCmds (ii:ii))
+ end do
+
+ ! make space for the array with all commands bioth upper and lower case.
+ allocate (character(len=lenCmd) :: allCmd (nSpaces+1)) ! might be more than needed bc superfluous spaces
+ allocate (character(len=lenCmd) :: allUpcaseCmd(nSpaces+1))
+ allocate (integer :: minLength (nSpaces+1))
+
+ ! Prepare lists of allowed commands and input commands
+ call tokenize (cmdTable, upcaseCmdTable, allCmd,allUpcaseCmd, minLength)
+ call tokenize (userCmds, upcaseUserCmds, inputCmd, upcaseInputCmd) ! 5th arg is optional
+
+ ! As first output line, print user input
+ write (*, '("Input: ", 10(A10,x))') (inputCmd(ip1), ip1=1, size(inputCmd))
+ write (*, '("Parsed: ")', advance='no')
+ ! Parse all user input commands
+ do ip1 = 1, size(inputCmd)
+ l = len_trim (inputCmd(ip1))
+ parsedCmd = invalid
+ do ip2 = 1, size(allCmd)
+ la =len_trim(allCmd(ip2))
+ if (la .ge. l) then ! input is possible abbreviation of this command
+ ! Case blind comparison
+ if (allUpcaseCmd(ip2)(:l) .eq. upcaseInputCmd (ip1) (:l)) then
+ ! at least this input cmd is a short form of this full command.
+ ! But is it valid?
+ if (minLength(ip2) .gt. l) then
+ cycle ! input is shorter than required minimum length, try next command
+ endif
+ else
+ cycle ! input does not match command
+ endif
+ ! Here we know that input an abbreviation of command,
+ ! and that it is not too short
+ parsedCmd = allUpcaseCmd (ip2) ! We have a result
+ exit ! no need to check input against following commands
+ else
+ ! input is longer than this command, nothing to do.
+ end if
+ end do
+ ! here we found the valid command, or the parsed value is still
+ write (*, '(A10,X)', advance='no') parsedCmd
+ end do
+ write (*,*) ! Terminate output line.
+
+contains
+
+ ! ======================================================================================
+ ! Divide a string of words separated by blanks into an array of the words without blanks
+ ! ======================================================================================
+ subroutine tokenize (tokenString, upCaseString, retList, upcaseRetList, minLength )
+
+ character (len=*), intent(in) :: tokenString, upcaseString ! input "as is" and "upcase"
+ character (len=lencmd), intent(out) :: retList(*), upcaseRetList(*) ! Result "as is" and "Upcase"
+ integer, intent(out), optional :: minLength(*) ! Minimum lengths of commands
+ integer :: ip1, ip2 ! pointers into tokenString
+ integer :: nTokens ! Counter forisolated words
+ integer :: lstr ! Length of the tokenString
+
+ ip1 = 1
+ nTokens = 0
+ lstr = len_trim (tokenString)
+ ! Expect keyword first, then an optional number.
+ do while (ip1 .le. lstr)
+ ! First scan for a command
+ do while (ip1 .le. lstr .and. tokenString (ip1:ip1) .eq. ' ') ! Skip space(s)
+ ip1 = ip1 + 1
+ end do
+
+ if (ip1 .le. lstr) then ! still inside Line?
+ ip2 = ip1
+ ! First expect keyword
+ do while (ip2 .le. lstr .and. tokenString (ip2:ip2) .ne. ' ') ! Find end of current word
+ ip2 = ip2 + 1
+ end do
+ ip2 = ip2 - 1 ! set to the true end of the new command, not one behind the next keyword
+ nTokens = nTokens + 1
+
+ retList (nTokens) = tokenString (ip1:ip2)
+ upcaseRetList (nTokens) = upcaseString (ip1:ip2)
+
+ ! Now go look for the number
+ ip1 = ip2 + 1 ! prepare to find start of next text (numeric or not)
+ if (ip1 .le. lstr) then ! Still not past the end of tokenString?
+ do while (ip1 .le. lstr .and. tokenString (ip1:ip1) .eq. ' ') ! Skip space(s)
+ ip1 = ip1 + 1
+ end do
+ if (isDigit (tokenString (ip1:ip1))) then
+ if (present (minLength)) then
+ ip2 = ip1
+ read (tokenString (ip1:), *) minLength (nTokens)
+ do while (ip2 .le. lstr .and. isDigit (tokenString(ip2:ip2)) ) ! Find end of current Number
+ ip2 = ip2 + 1
+ end do
+ ip1 = ip2 ! prepare for next text search. ip2 is already behind the number.
+ endif
+ endif
+ endif
+ endif
+ end do
+
+ end subroutine tokenize
+
+ ! =========================================================
+ ! Convert a character c to UPPER CASE, if its in lower case.
+ ! =========================================================
+
+ function toupper (c) result (U)
+ character, intent(in) :: c ! input
+ character :: U ! output
+ integer :: ix ! Helper: index of c in alphabet
+
+ Character(26), Parameter :: cap = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
+ Character(26), Parameter :: low = 'abcdefghijklmnopqrstuvwxyz'
+
+ ix = index (low, c) ! find c in lower case alphabet
+ if (ix .gt. 0) then ! c found: it is in lower case
+ U = cap (ix:ix) ! ...and needs conversion
+ else ! c not found, so is already in upper case,
+ U = c ! ...or it is not a letter. Just copy to result.
+ endif
+ end function toupper
+
+
+ ! ==========================================================
+ ! Returns .true. if input character c is in interval [0...9]
+ ! ==========================================================
+ function isDigit (c) result (YN)
+ character, intent(in) :: c
+ logical :: YN
+ YN = (index ('0123456789', c) .ne. 0)
+ end function isDigit
+
+end program AbbrSimple
diff --git a/Task/Abbreviations-simple/Go/abbreviations-simple.go b/Task/Abbreviations-simple/Go/abbreviations-simple.go
index d5cac0b13b..0f3e4d6af0 100644
--- a/Task/Abbreviations-simple/Go/abbreviations-simple.go
+++ b/Task/Abbreviations-simple/Go/abbreviations-simple.go
@@ -1,90 +1,90 @@
package main
import (
- "io"
- "os"
- "strconv"
- "strings"
- "text/tabwriter"
+ "io"
+ "os"
+ "strconv"
+ "strings"
+ "text/tabwriter"
)
func readTable(table string) ([]string, []int) {
- fields := strings.Fields(table)
- var commands []string
- var minLens []int
+ fields := strings.Fields(table)
+ var commands []string
+ var minLens []int
- for i, max := 0, len(fields); i < max; {
- cmd := fields[i]
- cmdLen := len(cmd)
- i++
+ for i, max := 0, len(fields); i < max; {
+ cmd := fields[i]
+ cmdLen := len(cmd)
+ i++
- if i < max {
- num, err := strconv.Atoi(fields[i])
- if err == nil && 1 <= num && num < cmdLen {
- cmdLen = num
- i++
- }
- }
+ if i < max {
+ num, err := strconv.Atoi(fields[i])
+ if err == nil && 1 <= num && num < cmdLen {
+ cmdLen = num
+ i++
+ }
+ }
- commands = append(commands, cmd)
- minLens = append(minLens, cmdLen)
- }
+ commands = append(commands, cmd)
+ minLens = append(minLens, cmdLen)
+ }
- return commands, minLens
+ return commands, minLens
}
func validateCommands(commands []string, minLens []int, words []string) []string {
- var results []string
- for _, word := range words {
- matchFound := false
- wlen := len(word)
- for i, command := range commands {
- if minLens[i] == 0 || wlen < minLens[i] || wlen > len(command) {
- continue
- }
- c := strings.ToUpper(command)
- w := strings.ToUpper(word)
- if strings.HasPrefix(c, w) {
- results = append(results, c)
- matchFound = true
- break
- }
- }
- if !matchFound {
- results = append(results, "*error*")
- }
- }
- return results
+ var results []string
+ for _, word := range words {
+ matchFound := false
+ wlen := len(word)
+ for i, command := range commands {
+ if minLens[i] == 0 || wlen < minLens[i] || wlen > len(command) {
+ continue
+ }
+ c := strings.ToUpper(command)
+ w := strings.ToUpper(word)
+ if strings.HasPrefix(c, w) {
+ results = append(results, c)
+ matchFound = true
+ break
+ }
+ }
+ if !matchFound {
+ results = append(results, "*error*")
+ }
+ }
+ return results
}
func printResults(words []string, results []string) {
- wr := tabwriter.NewWriter(os.Stdout, 0, 1, 1, ' ', 0)
- io.WriteString(wr, "user words:")
- for _, word := range words {
- io.WriteString(wr, "\t"+word)
- }
- io.WriteString(wr, "\n")
- io.WriteString(wr, "full words:\t"+strings.Join(results, "\t")+"\n")
- wr.Flush()
+ wr := tabwriter.NewWriter(os.Stdout, 0, 1, 1, ' ', 0)
+ io.WriteString(wr, "user words:")
+ for _, word := range words {
+ io.WriteString(wr, "\t"+word)
+ }
+ io.WriteString(wr, "\n")
+ io.WriteString(wr, "full words:\t"+strings.Join(results, "\t")+"\n")
+ wr.Flush()
}
func main() {
- const table = "" +
- "add 1 alter 3 backup 2 bottom 1 Cappend 2 change 1 Schange Cinsert 2 Clast 3 " +
- "compress 4 copy 2 count 3 Coverlay 3 cursor 3 delete 3 Cdelete 2 down 1 duplicate " +
- "3 xEdit 1 expand 3 extract 3 find 1 Nfind 2 Nfindup 6 NfUP 3 Cfind 2 findUP 3 fUP 2 " +
- "forward 2 get help 1 hexType 4 input 1 powerInput 3 join 1 split 2 spltJOIN load " +
- "locate 1 Clocate 2 lowerCase 3 upperCase 3 Lprefix 2 macro merge 2 modify 3 move 2 " +
- "msg next 1 overlay 1 parse preserve 4 purge 3 put putD query 1 quit read recover 3 " +
- "refresh renum 3 repeat 3 replace 1 Creplace 2 reset 3 restore 4 rgtLEFT right 2 left " +
- "2 save set shift 2 si sort sos stack 3 status 4 top transfer 3 type 1 up 1 "
+ const table = "" +
+ "add 1 alter 3 backup 2 bottom 1 Cappend 2 change 1 Schange Cinsert 2 Clast 3 " +
+ "compress 4 copy 2 count 3 Coverlay 3 cursor 3 delete 3 Cdelete 2 down 1 duplicate " +
+ "3 xEdit 1 expand 3 extract 3 find 1 Nfind 2 Nfindup 6 NfUP 3 Cfind 2 findUP 3 fUP 2 " +
+ "forward 2 get help 1 hexType 4 input 1 powerInput 3 join 1 split 2 spltJOIN load " +
+ "locate 1 Clocate 2 lowerCase 3 upperCase 3 Lprefix 2 macro merge 2 modify 3 move 2 " +
+ "msg next 1 overlay 1 parse preserve 4 purge 3 put putD query 1 quit read recover 3 " +
+ "refresh renum 3 repeat 3 replace 1 Creplace 2 reset 3 restore 4 rgtLEFT right 2 left " +
+ "2 save set shift 2 si sort sos stack 3 status 4 top transfer 3 type 1 up 1 "
- const sentence = "riG rePEAT copies put mo rest types fup. 6 poweRin"
+ const sentence = "riG rePEAT copies put mo rest types fup. 6 poweRin"
- commands, minLens := readTable(table)
- words := strings.Fields(sentence)
+ commands, minLens := readTable(table)
+ words := strings.Fields(sentence)
- results := validateCommands(commands, minLens, words)
+ results := validateCommands(commands, minLens, words)
- printResults(words, results)
+ printResults(words, results)
}
diff --git a/Task/Abbreviations-simple/M2000-Interpreter/abbreviations-simple-1.m2000 b/Task/Abbreviations-simple/M2000-Interpreter/abbreviations-simple-1.m2000
index 90d9a00bf6..cb21cfad50 100644
--- a/Task/Abbreviations-simple/M2000-Interpreter/abbreviations-simple-1.m2000
+++ b/Task/Abbreviations-simple/M2000-Interpreter/abbreviations-simple-1.m2000
@@ -1,56 +1,56 @@
Module Abbreviations_Simple {
- Function Lex {
- a$={add 1 alter 3 backup 2 bottom 1 Cappend 2 change 1 Schange Cinsert 2 Clast 3
- compress 4 copy 2 count 3 Coverlay 3 cursor 3 delete 3 Cdelete 2 down 1 duplicate
- 3 xEdit 1 expand 3 extract 3 find 1 Nfind 2 Nfindup 6 NfUP 3 Cfind 2 findUP 3 fUP 2
- forward 2 get help 1 hexType 4 input 1 powerInput 3 join 1 split 2 spltJOIN load
- locate 1 Clocate 2 lowerCase 3 upperCase 3 Lprefix 2 macro merge 2 modify 3 move 2
- msg next 1 overlay 1 parse preserve 4 purge 3 put putD query 1 quit read recover 3
- refresh renum 3 repeat 3 replace 1 Creplace 2 reset 3 restore 4 rgtLEFT right 2 left
- 2 save set shift 2 si sort sos stack 3 status 4 top transfer 3 type 1 up 1
- }
- const crlftab$={
- }+chr$(9)
-
- Lex=Queue
- Word$=""
- dim part$()
- part$()=piece$(trim$(filter$(a$, crlftab$)), " ")
- for i=0 to len(part$())-1
- if part$(i)<>"" then
- k=val(part$(i))
- if k=0 then
- if Word$<>"" then Append Lex, Word$:=Word$
- Word$=ucase$(part$(i))
- else
- for j=k to len(Word$)
- Append Lex, left$(Word$,j):=Word$
- next j
- word$=""
- end if
- end if
- next i
- if Word$<>"" then Append Lex, Word$:=Word$
- =Lex
- }
- Parse$=Lambda$ Lex=Lex() (a$) -> {
- Dim part$()
- Rep$=""
- part$()=piece$(a$," ")
- if len(part$())=0 then exit
- for i=0 to len(part$())-1
- if part$(i)<>"" then
- if exist(Lex, ucase$(part$(i))) then
- Rep$+=if$(Rep$=""->"", " ")+Eval$(lex)
- else
- Rep$+=if$(Rep$=""->"", " ")+"*error*"
- end if
- end if
- next i
- =Rep$
- }
- Print Parse$("riG rePEAT copies put mo rest types fup. 6 poweRin")
- Print Parse$("riG macro copies macr")
- Print Parse$("")=""
+ Function Lex {
+ a$={add 1 alter 3 backup 2 bottom 1 Cappend 2 change 1 Schange Cinsert 2 Clast 3
+ compress 4 copy 2 count 3 Coverlay 3 cursor 3 delete 3 Cdelete 2 down 1 duplicate
+ 3 xEdit 1 expand 3 extract 3 find 1 Nfind 2 Nfindup 6 NfUP 3 Cfind 2 findUP 3 fUP 2
+ forward 2 get help 1 hexType 4 input 1 powerInput 3 join 1 split 2 spltJOIN load
+ locate 1 Clocate 2 lowerCase 3 upperCase 3 Lprefix 2 macro merge 2 modify 3 move 2
+ msg next 1 overlay 1 parse preserve 4 purge 3 put putD query 1 quit read recover 3
+ refresh renum 3 repeat 3 replace 1 Creplace 2 reset 3 restore 4 rgtLEFT right 2 left
+ 2 save set shift 2 si sort sos stack 3 status 4 top transfer 3 type 1 up 1
+ }
+ const crlftab$={
+ }+chr$(9)
+
+ Lex=Queue
+ Word$=""
+ dim part$()
+ part$()=piece$(trim$(filter$(a$, crlftab$)), " ")
+ for i=0 to len(part$())-1
+ if part$(i)<>"" then
+ k=val(part$(i))
+ if k=0 then
+ if Word$<>"" then Append Lex, Word$:=Word$
+ Word$=ucase$(part$(i))
+ else
+ for j=k to len(Word$)
+ Append Lex, left$(Word$,j):=Word$
+ next j
+ word$=""
+ end if
+ end if
+ next i
+ if Word$<>"" then Append Lex, Word$:=Word$
+ =Lex
+ }
+ Parse$=Lambda$ Lex=Lex() (a$) -> {
+ Dim part$()
+ Rep$=""
+ part$()=piece$(a$," ")
+ if len(part$())=0 then exit
+ for i=0 to len(part$())-1
+ if part$(i)<>"" then
+ if exist(Lex, ucase$(part$(i))) then
+ Rep$+=if$(Rep$=""->"", " ")+Eval$(lex)
+ else
+ Rep$+=if$(Rep$=""->"", " ")+"*error*"
+ end if
+ end if
+ next i
+ =Rep$
+ }
+ Print Parse$("riG rePEAT copies put mo rest types fup. 6 poweRin")
+ Print Parse$("riG macro copies macr")
+ Print Parse$("")=""
}
Abbreviations_Simple
diff --git a/Task/Abbreviations-simple/M2000-Interpreter/abbreviations-simple-2.m2000 b/Task/Abbreviations-simple/M2000-Interpreter/abbreviations-simple-2.m2000
index 7cb46266da..3572afdec0 100644
--- a/Task/Abbreviations-simple/M2000-Interpreter/abbreviations-simple-2.m2000
+++ b/Task/Abbreviations-simple/M2000-Interpreter/abbreviations-simple-2.m2000
@@ -1,66 +1,66 @@
Module Abbreviations_Simple_2 {
- Function Lex$ {
- a$={add 1 alter 3 backup 2 bottom 1 Cappend 2 change 1 Schange Cinsert 2 Clast 3
- compress 4 copy 2 count 3 Coverlay 3 cursor 3 delete 3 Cdelete 2 down 1 duplicate
- 3 xEdit 1 expand 3 extract 3 find 1 Nfind 2 Nfindup 6 NfUP 3 Cfind 2 findUP 3 fUP 2
- forward 2 get help 1 hexType 4 input 1 powerInput 3 join 1 split 2 spltJOIN load
- locate 1 Clocate 2 lowerCase 3 upperCase 3 Lprefix 2 macro merge 2 modify 3 move 2
- msg next 1 overlay 1 parse preserve 4 purge 3 put putD query 1 quit read recover 3
- refresh renum 3 repeat 3 replace 1 Creplace 2 reset 3 restore 4 rgtLEFT right 2 left
- 2 save set shift 2 si sort sos stack 3 status 4 top transfer 3 type 1 up 1
- }
- const crlftab$={
- }+chr$(9)
-
- Lex$=""
- Word$=""
- dim part$()
- part$()=piece$(trim$(filter$(a$, crlftab$)), " ")
- for i=0 to len(part$())-1
- if part$(i)<>"" then
- k=val(part$(i))
- if k=0 then
- if Word$<>"" then Lex$+="#"+Word$+" 0"
- Word$=ucase$(part$(i))
- else
- Lex$+="#"+ Word$+str$(k)
- word$=""
- end if
- end if
- next i
- if Word$<>"" then Lex$+="#"+Word$+" 0"
- =Lex$
- }
- Parse$=Lambda$ Lex$=Lex$() (a$) -> {
- Dim part$()
- Rep$=""
- part$()=piece$(a$," ")
- if len(part$())=0 then exit
- for i=0 to len(part$())-1
- if part$(i)<>"" then
- j=1
- do
- j=instr(Lex$, "#"+ucase$(part$(i)), j)
- if j=0 then exit
- q=instr(Lex$, " ", j+1)
- if Val(Mid$(lex$, q,10))=0 then
- if Mid$(Lex$, j+1, q-j)=ucase$(part$(i))+" " then exit
- else.if len(part$(i))>=Val(Mid$(lex$, q,10)) then
- exit
- end if
- j++
- Always
- if j>0 then
- Rep$+=if$(Rep$=""->"", " ")+Mid$(Lex$, j+1, q-j-1)
- else
- Rep$+=if$(Rep$=""->"", " ")+"*error*"
- end if
- end if
- next i
- =Rep$
- }
- Print Parse$("riG rePEAT copies put mo rest types fup. 6 poweRin")
- Print Parse$("riG macro copies macr")
- Print Parse$("")=""
+ Function Lex$ {
+ a$={add 1 alter 3 backup 2 bottom 1 Cappend 2 change 1 Schange Cinsert 2 Clast 3
+ compress 4 copy 2 count 3 Coverlay 3 cursor 3 delete 3 Cdelete 2 down 1 duplicate
+ 3 xEdit 1 expand 3 extract 3 find 1 Nfind 2 Nfindup 6 NfUP 3 Cfind 2 findUP 3 fUP 2
+ forward 2 get help 1 hexType 4 input 1 powerInput 3 join 1 split 2 spltJOIN load
+ locate 1 Clocate 2 lowerCase 3 upperCase 3 Lprefix 2 macro merge 2 modify 3 move 2
+ msg next 1 overlay 1 parse preserve 4 purge 3 put putD query 1 quit read recover 3
+ refresh renum 3 repeat 3 replace 1 Creplace 2 reset 3 restore 4 rgtLEFT right 2 left
+ 2 save set shift 2 si sort sos stack 3 status 4 top transfer 3 type 1 up 1
+ }
+ const crlftab$={
+ }+chr$(9)
+
+ Lex$=""
+ Word$=""
+ dim part$()
+ part$()=piece$(trim$(filter$(a$, crlftab$)), " ")
+ for i=0 to len(part$())-1
+ if part$(i)<>"" then
+ k=val(part$(i))
+ if k=0 then
+ if Word$<>"" then Lex$+="#"+Word$+" 0"
+ Word$=ucase$(part$(i))
+ else
+ Lex$+="#"+ Word$+str$(k)
+ word$=""
+ end if
+ end if
+ next i
+ if Word$<>"" then Lex$+="#"+Word$+" 0"
+ =Lex$
+ }
+ Parse$=Lambda$ Lex$=Lex$() (a$) -> {
+ Dim part$()
+ Rep$=""
+ part$()=piece$(a$," ")
+ if len(part$())=0 then exit
+ for i=0 to len(part$())-1
+ if part$(i)<>"" then
+ j=1
+ do
+ j=instr(Lex$, "#"+ucase$(part$(i)), j)
+ if j=0 then exit
+ q=instr(Lex$, " ", j+1)
+ if Val(Mid$(lex$, q,10))=0 then
+ if Mid$(Lex$, j+1, q-j)=ucase$(part$(i))+" " then exit
+ else.if len(part$(i))>=Val(Mid$(lex$, q,10)) then
+ exit
+ end if
+ j++
+ Always
+ if j>0 then
+ Rep$+=if$(Rep$=""->"", " ")+Mid$(Lex$, j+1, q-j-1)
+ else
+ Rep$+=if$(Rep$=""->"", " ")+"*error*"
+ end if
+ end if
+ next i
+ =Rep$
+ }
+ Print Parse$("riG rePEAT copies put mo rest types fup. 6 poweRin")
+ Print Parse$("riG macro copies macr")
+ Print Parse$("")=""
}
Abbreviations_Simple_2
diff --git a/Task/Abbreviations-simple/M2000-Interpreter/abbreviations-simple-3.m2000 b/Task/Abbreviations-simple/M2000-Interpreter/abbreviations-simple-3.m2000
index e710dbc3c6..856910db96 100644
--- a/Task/Abbreviations-simple/M2000-Interpreter/abbreviations-simple-3.m2000
+++ b/Task/Abbreviations-simple/M2000-Interpreter/abbreviations-simple-3.m2000
@@ -1,71 +1,71 @@
Module Abbreviations_simple {
- commands=list
- a$="add 1 alter 3 backup 2 bottom 1 Cappend 2 change 1 Schange Cinsert 2 Clast 3 "
- a$+="compress 4 copy 2 count 3 Coverlay 3 cursor 3 delete 3 Cdelete 2 down 1 duplicate "
- a$+="3 xEdit 1 expand 3 extract 3 find 1 Nfind 2 Nfindup 6 NfUP 3 Cfind 2 findUP 3 fUP 2 "
- a$+="forward 2 get help 1 hexType 4 input 1 powerInput 3 join 1 split 2 spltJOIN load "
- a$+="locate 1 Clocate 2 lowerCase 3 upperCase 3 Lprefix 2 macro merge 2 modify 3 move 2 "
- a$+="msg next 1 overlay 1 parse preserve 4 purge 3 put putD query 1 quit read recover 3 "
- a$+="refresh renum 3 repeat 3 replace 1 Creplace 2 reset 3 restore 4 rgtLEFT right 2 left "
- a$+="2 save set shift 2 si sort sos stack 3 status 4 top transfer 3 type 1 up 1"
- gosub cleanspaces
- gosub makelist
- if not empty then gosub processstack
- a$="riG rePEAT copies put mo rest types fup. 6 poweRin"
- Print a$
- gosub cleanspaces
- gosub findresult
- a$="riG macro copies macr"
- Print a$
- gosub cleanspaces
- gosub findresult
- End
+ commands=list
+ a$="add 1 alter 3 backup 2 bottom 1 Cappend 2 change 1 Schange Cinsert 2 Clast 3 "
+ a$+="compress 4 copy 2 count 3 Coverlay 3 cursor 3 delete 3 Cdelete 2 down 1 duplicate "
+ a$+="3 xEdit 1 expand 3 extract 3 find 1 Nfind 2 Nfindup 6 NfUP 3 Cfind 2 findUP 3 fUP 2 "
+ a$+="forward 2 get help 1 hexType 4 input 1 powerInput 3 join 1 split 2 spltJOIN load "
+ a$+="locate 1 Clocate 2 lowerCase 3 upperCase 3 Lprefix 2 macro merge 2 modify 3 move 2 "
+ a$+="msg next 1 overlay 1 parse preserve 4 purge 3 put putD query 1 quit read recover 3 "
+ a$+="refresh renum 3 repeat 3 replace 1 Creplace 2 reset 3 restore 4 rgtLEFT right 2 left "
+ a$+="2 save set shift 2 si sort sos stack 3 status 4 top transfer 3 type 1 up 1"
+ gosub cleanspaces
+ gosub makelist
+ if not empty then gosub processstack
+ a$="riG rePEAT copies put mo rest types fup. 6 poweRin"
+ Print a$
+ gosub cleanspaces
+ gosub findresult
+ a$="riG macro copies macr"
+ Print a$
+ gosub cleanspaces
+ gosub findresult
+ End
processstack:
- Read many, word$
- if many>0 and many0 and many"" then data 0, ucase$(w$):w$=""
- end if
- next
- return
+ let b$="", w$="", n$=""
+ flush
+ for i=1 to len(A$)
+ c$=mid$(a$, i, 1)
+ if c$~"[a-zA-Z]" then
+ if w$="" and not empty then gosub processstack
+ w$+=c$
+ else.if c$~"[1-9]" then
+ drop : push val(c$)
+ else
+ if w$<>"" then data 0, ucase$(w$):w$=""
+ end if
+ next
+ return
findresult:
- dim a$()
- a$()=piece$(ucase$(a$), " ")
- flush
- for i=0 to len(a$())-1
- if exist(commands, a$(i)) then
- Data eval$(commands)
- else
- Data "*error*"
- end if
- next
- Print Array([])#str$(" ")
- Return
+ dim a$()
+ a$()=piece$(ucase$(a$), " ")
+ flush
+ for i=0 to len(a$())-1
+ if exist(commands, a$(i)) then
+ Data eval$(commands)
+ else
+ Data "*error*"
+ end if
+ next
+ Print Array([])#str$(" ")
+ Return
}
Abbreviations_simple
diff --git a/Task/Abbreviations-simple/Pluto/abbreviations-simple.pluto b/Task/Abbreviations-simple/Pluto/abbreviations-simple.pluto
new file mode 100644
index 0000000000..5354c7545d
--- /dev/null
+++ b/Task/Abbreviations-simple/Pluto/abbreviations-simple.pluto
@@ -0,0 +1,102 @@
+do -- Abbreviatiions Simple - expand command name abbreviations
+
+ -- returns the table of space delimited words in s
+ local function getWords( s : string ) : table
+ local t, cmds, w = s, {}, s
+ while t:contains( " " ) do
+ w, t = t:partition( " " )
+ if w != "" then
+ cmds[ # cmds + 1 ] = w
+ end
+ end
+ if t != "" then
+ cmds[ # cmds + 1 ] = t
+ end
+ return cmds
+ end
+
+ local commandStrings
+ = "add 1 alter 3 backup 2 bottom 1 Cappend 2 change 1 Schange Cinsert 2 Clast 3"
+ .. " compress 4 copy 2 count 3 Coverlay 3 cursor 3 delete 3 Cdelete 2 down 1 duplicate"
+ .. " 3 xEdit 1 expand 3 extract 3 find 1 Nfind 2 Nfindup 6 NfUP 3 Cfind 2 findUP 3 fUP 2"
+ .. " forward 2 get help 1 hexType 4 input 1 powerInput 3 join 1 split 2 spltJOIN load"
+ .. " locate 1 Clocate 2 lowerCase 3 upperCase 3 Lprefix 2 macro merge 2 modify 3 move 2"
+ .. " msg next 1 overlay 1 parse preserve 4 purge 3 put putD query 1 quit read recover 3"
+ .. " refresh renum 3 repeat 3 replace 1 Creplace 2 reset 3 restore 4 rgtLEFT right 2 left"
+ .. " 2 save set shift 2 si sort sos stack 3 status 4 top transfer 3 type 1 up 1"
+
+ local function expandEasyAbbreviations( cmds : string, input : string ) : table
+ local cmdTable, inputTable, outputTable = getWords( cmds ), getWords( input ), {}
+
+ local function isCommand( cmd : string, word : string ) : boolean
+ local result, uCmd, uWord = false, cmd:upper(), word:upper()
+ if # cmd >= # word then -- word is not longer than the command
+ if uCmd == uWord then -- the word is the command
+ result = true
+ else -- word is shorter than the command
+ local ab = cmd:gsub( "%l", "" ) -- remove lowercase
+ if # ab <= # word then -- the minimum abbreviation isn't longer than the word
+ result = uWord == uCmd:sub( 1, # word )
+ end
+ end
+ end
+ return result
+ end
+
+ for i = 1, # inputTable do
+ local w, u = inputTable[ i ], "*error*"
+ for c = 1, # cmdTable do
+ if isCommand( cmdTable[ c ], w ) then
+ u = cmdTable[ c ]:upper()
+ break
+ end
+ end
+ outputTable[ # outputTable + 1 ] = u
+ end
+ return { inputTable, outputTable }
+ end
+
+ local function printExpansion( expansion : table )
+ local fmt, input, output = {}, expansion[ 1 ], expansion[ 2 ]
+ for i, v in ipairs( output ) do
+ fmt[ i ] = " %" .. # v .. "s"
+ end
+ io.write( "Input: " )
+ for i, v in ipairs( input ) do
+ io.write( string.format( fmt[ i ], v ) )
+ end
+ io.write( "\nOutput:" )
+ for i, v in ipairs( output ) do
+ io.write( string.format( fmt[ i ], v ) )
+ end
+ io.write( "\n" )
+ end
+
+ -- maps a "simple" format command list to "easy" format
+ local function simpleToEasyFormat( cmds : string ) : string
+ local words = getWords( cmds )
+ local wPos, wMax, easy = 1, # words, ""
+ while wPos <= wMax do
+ local w = words[ wPos ]
+ local lenStr = if wPos == wMax then "" else words[ wPos + 1 ] end
+ if not lenStr:match( "^%d+$" ) then
+ easy ..= " " .. w:upper()
+ else
+ -- have a minimum length
+ local len = tonumber( lenStr )
+ easy ..= " " .. w:sub( 1, len ):upper()
+ if len < # w then easy ..= w:sub( len + 1, -1 ):lower() end
+ ++ wPos
+ end
+ ++ wPos
+ end
+ return easy
+ end
+
+ printExpansion( expandEasyAbbreviations( simpleToEasyFormat( commandStrings )
+ , ( "riG rePEAT copies put mo rest "
+ .. "types fup. 6 poweRin"
+ )
+ )
+ )
+end
diff --git a/Task/Abbreviations-simple/Rebol/abbreviations-simple.rebol b/Task/Abbreviations-simple/Rebol/abbreviations-simple.rebol
new file mode 100644
index 0000000000..4a08df3f58
--- /dev/null
+++ b/Task/Abbreviations-simple/Rebol/abbreviations-simple.rebol
@@ -0,0 +1,66 @@
+Rebol [
+ title: "Rosetta code: Abbreviations, simple"
+ file: %Abbreviations,_simple.r3
+ url: https://rosettacode.org/wiki/Abbreviations,_simple
+]
+
+find-abbreviation-lengths: function [
+ "Find minimal abbreviation length for each command"
+ text [string!]
+][
+ result: make map! []
+ parse transcode text [
+ some [
+ set cmd: word! (cmd: form cmd)
+ [set len: integer! | (len: length? cmd)]
+ (result/:cmd: len)
+ ]
+ ]
+ result
+]
+
+build-abbreviations-table: function [
+ "Expand each command into all valid abbreviations"
+ cmd-lengths [map!]
+][
+ result: make map! []
+ foreach [cmd min-len] cmd-lengths [
+ cmd-up: uppercase copy cmd
+ ;; step down from full length to min-len
+ for i length? cmd min-len -1 [
+ abbr: lowercase copy/part cmd i
+ result/:abbr: cmd-up
+ ]
+ ]
+ result
+]
+
+split-commands: function/with [commands [string!]][
+ out: copy []
+ parse commands [
+ any [any delimit copy cmd: some chars (append out cmd)]
+ ]
+ out
+][
+ delimit: charset " ^-^/"
+ chars: complement delimit
+]
+
+abbrevs: build-abbreviations-table find-abbreviation-lengths {
+ add 1 alter 3 backup 2 bottom 1 Cappend 2 change 1 Schange Cinsert 2 Clast 3
+ compress 4 copy 2 count 3 Coverlay 3 cursor 3 delete 3 Cdelete 2 down 1 duplicate
+ 3 xEdit 1 expand 3 extract 3 find 1 Nfind 2 Nfindup 6 NfUP 3 Cfind 2 findUP 3 fUP 2
+ forward 2 get help 1 hexType 4 input 1 powerInput 3 join 1 split 2 spltJOIN load
+ locate 1 Clocate 2 lowerCase 3 upperCase 3 Lprefix 2 macro merge 2 modify 3 move 2
+ msg next 1 overlay 1 parse preserve 4 purge 3 put putD query 1 quit read recover 3
+ refresh renum 3 repeat 3 replace 1 Creplace 2 reset 3 restore 4 rgtLEFT right 2 left
+ 2 save set shift 2 si sort sos stack 3 status 4 top transfer 3 type 1 up 1}
+
+
+inputs: split-commands {
+ riG rePEAT copies put mo rest types fup. 6 poweRin}
+
+foreach cmd inputs [
+ full: any [abbrevs/:cmd "*error*"]
+ print [pad cmd 10 '-> full]
+]
diff --git a/Task/Abbreviations-simple/SNOBOL4/abbreviations-simple.sno b/Task/Abbreviations-simple/SNOBOL4/abbreviations-simple.sno
index 47e5e52dde..5c156c5349 100644
--- a/Task/Abbreviations-simple/SNOBOL4/abbreviations-simple.sno
+++ b/Task/Abbreviations-simple/SNOBOL4/abbreviations-simple.sno
@@ -3,7 +3,7 @@
* Description: Abbreviations, simple
* Comment: Tested using the Spitbol for Linux version of SNOBOL4
- commands =
+ commands =
+ "add 1 alter 3 backup 2 bottom 1 Cappend 2 change 1 Schange Cinsert 2 Clast 3 "
+ "compress 4 copy 2 count 3 Coverlay 3 cursor 3 delete 3 Cdelete 2 down 1 duplicate "
+ "3 xEdit 1 expand 3 extract 3 find 1 Nfind 2 Nfindup 6 NfUP 3 Cfind 2 findUP 3 fUP 2 "
@@ -13,49 +13,49 @@
+ "refresh renum 3 repeat 3 replace 1 Creplace 2 reset 3 restore 4 rgtLEFT right 2 left "
+ "2 save set shift 2 si sort sos stack 3 status 4 top transfer 3 type 1 up 1 "
- commands = replace(commands,&lcase,&ucase)
- numerals = '0123456789'
+ commands = replace(commands,&lcase,&ucase)
+ numerals = '0123456789'
* Function filltable will fill the command abbreviations table
- define("filltable(s,n)slen,i")
- ct = table(300, ,"*error*") :f(errr);* command abbreviations table
- :(filltable_end)
+ define("filltable(s,n)slen,i")
+ ct = table(300, ,"*error*") :f(errr);* command abbreviations table
+ :(filltable_end)
filltable
- slen = size(s)
- ct[s] = s
- eq(n,slen) :s(filltable3)
- i = n - 1
+ slen = size(s)
+ ct[s] = s
+ eq(n,slen) :s(filltable3)
+ i = n - 1
filltable2
- i = lt(i,slen - 1) i + 1 :f(filltable3)
- ct[substr(s,1,i)] = s
- :(filltable2)
+ i = lt(i,slen - 1) i + 1 :f(filltable3)
+ ct[substr(s,1,i)] = s
+ :(filltable2)
filltable3
- filltable = ""
- :(return)
+ filltable = ""
+ :(return)
filltable_end
x0
* Populate command abbreviations table
- commands ? (span(' ') | "") breakx(&ucase) span(&ucase) . c
-+ span(' ') (span(numerals) | "") . ablen = "" :f(x1)
- ablen = ident(ablen) size(c)
- ret = filltable(c,ablen)
+ commands ? (span(' ') | "") breakx(&ucase) span(&ucase) . c
++ span(' ') (span(numerals) | "") . ablen = "" :f(x1)
+ ablen = ident(ablen) size(c)
+ ret = filltable(c,ablen)
:(x0)
x1
* Process user string
- userstring = "riG rePEAT copies put mo rest types fup. 6 poweRin"
- output = "Original user string:"
- output = userstring
- userstring = replace(userstring,&lcase,&ucase)
+ userstring = "riG rePEAT copies put mo rest types fup. 6 poweRin"
+ output = "Original user string:"
+ output = userstring
+ userstring = replace(userstring,&lcase,&ucase)
x2
- userstring ? (span(' ') | "") (break(' ') | (len(1) rem)) . c = "" :f(x3)
- user_commands = (gt(size(user_commands),0) user_commands ' ' ct[c], ct[c])
- :(x2)
+ userstring ? (span(' ') | "") (break(' ') | (len(1) rem)) . c = "" :f(x3)
+ user_commands = (gt(size(user_commands),0) user_commands ' ' ct[c], ct[c])
+ :(x2)
x3
- output = ""
- output = "User string with abbreviations expanded:"
- output = user_commands
+ output = ""
+ output = "User string with abbreviations expanded:"
+ output = user_commands
END
diff --git a/Task/Abbreviations-simple/VBScript/abbreviations-simple.vbs b/Task/Abbreviations-simple/VBScript/abbreviations-simple.vbs
new file mode 100644
index 0000000000..23328381b6
--- /dev/null
+++ b/Task/Abbreviations-simple/VBScript/abbreviations-simple.vbs
@@ -0,0 +1,88 @@
+option explicit
+
+function iif(c,t,f) if c then iif=t else iif=f end if: end function
+function usrin(pr) wscript.stdout.write vbcrlf &pr &": ":usrin= wscript.stdin.readline:end function
+
+sub do_abbrev
+ dim j, sm,n,n0,a
+ for each j in m
+ sm=trim(lcase(j.submatches(0)))
+ n0=iif (j.submatches(1)="",1, j.submatches(1))
+ n=1
+ do
+ a=left(sm,n)
+ if not d.exists(a) then
+ d.add a,sm
+ else
+ if len(a)=len(sm) then
+ d(a)=sm
+ elseif len(d(a))>len(a) then
+ d(a)=null
+ end if
+ end if
+ n=n+1
+ loop until n>len(sm)
+ next
+end sub
+'output sorted
+
+sub display
+ dim d2,k,j,kk,mm
+ set d2=createobject("Scripting.dictionary")
+ for each k in d
+ kk=d(k)
+ if not isnull(kk) then
+ if not d2.exists(kk) then
+ d2.add kk,k
+ else
+ d2(kk)= d2(kk) & " " & k
+ end if
+ end if
+ next
+ for each j in m
+ mm=trim(lcase(j.submatches(0)))
+ wscript.echo left(mm&space(15),15),d2(mm)
+ next
+ wscript.echo
+ set d2=nothing
+end sub
+
+sub test
+ wscript.echo vbcrlf&"test:"
+ dim a,i,k,s1
+ do
+ s1= lcase(usrin("Command?"))
+ if trim(s1)="" then wscript.quit
+ a=split(trim(s1)," ")
+ for i=0 to ubound(a)
+ if a(i)<>"" then
+ wscript.stdout.write iif (d.exists(a(i)), ucase(d(a(i)))," **ERROR**")& " "
+ end if
+ next
+ loop
+end sub
+
+'main program
+dim s:s=_
+ "add 1 alter 3 backup 2 bottom 1 Cappend 2 change 1 Schange Cinsert 2 Clast 3 "&_
+ "compress 4 copy 2 count 3 Coverlay 3 cursor 3 delete 3 Cdelete 2 down 1 duplicate "&_
+ "3 xEdit 1 expand 3 extract 3 find 1 Nfind 2 Nfindup 6 NfUP 3 Cfind 2 findUP 3 fUP 2 "&_
+ "forward 2 get help 1 hexType 4 input 1 powerInput 3 join 1 split 2 spltJOIN load "&_
+ "locate 1 Clocate 2 lowerCase 3 upperCase 3 Lprefix 2 macro merge 2 modify 3 move 2 "&_
+ "msg next 1 overlay 1 parse preserve 4 purge 3 put putD query 1 quit read recover 3 "&_
+ "refresh renum 3 repeat 3 replace 1 Creplace 2 reset 3 restore 4 rgtLEFT right 2 left "&_
+ "2 save set shift 2 si sort sos stack 3 status 4 top transfer 3 type 1 up 1 "
+dim m,d
+
+'use regexp to separate input
+with new regexp
+ .pattern="([a-z]+?)\s+(\d?)"
+ .global=true
+ .ignorecase=true
+ set m=.execute(s)
+end with
+
+set d=createobject("Scripting.dictionary")
+do_abbrev
+'display
+test
diff --git a/Task/Abbreviations-simple/Zkl/abbreviations-simple.zkl b/Task/Abbreviations-simple/Zkl/abbreviations-simple.zkl
index dde5b77dd6..107e7dba15 100644
--- a/Task/Abbreviations-simple/Zkl/abbreviations-simple.zkl
+++ b/Task/Abbreviations-simple/Zkl/abbreviations-simple.zkl
@@ -1,4 +1,4 @@
-commands:=Data(0,String, // "add\01\0alter\0..."
+commands:=Data(0,String, // "add\01\0alter\0..."
#<<<
"add 1 alter 3 backup 2 bottom 1 Cappend 2 change 1 Schange Cinsert 2 Clast 3
compress 4 copy 2 count 3 Coverlay 3 cursor 3 delete 3 Cdelete 2 down 1 duplicate
@@ -16,7 +16,7 @@ n:=0; while(n=szs.find(n,99999)) return(c);
n+=c.len();
diff --git a/Task/Abelian-sandpile-model-Identity/Ada/abelian-sandpile-model-identity-1.adb b/Task/Abelian-sandpile-model-Identity/Ada/abelian-sandpile-model-identity-1.adb
new file mode 100644
index 0000000000..2683729e0b
--- /dev/null
+++ b/Task/Abelian-sandpile-model-Identity/Ada/abelian-sandpile-model-identity-1.adb
@@ -0,0 +1,15 @@
+-- Works with Ada 2012
+
+package Abelian_Sandpile is
+ Limit : constant Integer := 4;
+
+ type Sandpile is array (0 .. 2, 0 .. 2) of Natural with
+ Default_Component_Value => 0;
+
+ procedure Stabalize (Pile : in out Sandpile);
+ function Is_Stable (Pile : in Sandpile) return Boolean;
+ procedure Topple (Pile : in out Sandpile);
+ function "+" (Left, Right : Sandpile) return Sandpile;
+ procedure Print(PIle : in Sandpile);
+
+end Abelian_Sandpile;
diff --git a/Task/Abelian-sandpile-model-Identity/Ada/abelian-sandpile-model-identity-2.adb b/Task/Abelian-sandpile-model-Identity/Ada/abelian-sandpile-model-identity-2.adb
new file mode 100644
index 0000000000..8e38a56088
--- /dev/null
+++ b/Task/Abelian-sandpile-model-Identity/Ada/abelian-sandpile-model-identity-2.adb
@@ -0,0 +1,85 @@
+with Ada.Text_Io; use Ada.Text_IO;
+
+package body Abelian_Sandpile is
+
+ ---------------
+ -- Stabalize --
+ ---------------
+
+ procedure Stabalize (Pile : in out Sandpile) is
+ begin
+ while not Is_Stable(Pile) loop
+ Topple(Pile);
+ end loop;
+ end Stabalize;
+
+ ---------------
+ -- Is_Stable --
+ ---------------
+
+ function Is_Stable (Pile : in Sandpile) return Boolean is
+ begin
+ return (for all E of Pile => E < Limit);
+ end Is_Stable;
+
+ ------------
+ -- Topple --
+ ------------
+
+ procedure Topple (Pile : in out Sandpile) is
+ begin
+ outer:
+ for Row in Pile'Range(1) loop
+ for Col in Pile'Range(2) loop
+ if Pile(Row, Col) >= Limit then
+ Pile(Row, Col) := Pile(Row, Col) - Limit;
+ if Row > 0 then
+ Pile(Row - 1, Col) := Pile(Row -1, Col) + 1;
+ end if;
+ if Row < Pile'Last(1) then
+ Pile(Row + 1, Col) := Pile(Row + 1, Col) + 1;
+ end if;
+ if Col > 0 then
+ Pile(Row, Col - 1) := Pile(Row, Col - 1) + 1;
+ end if;
+ if Col < Pile'Last(2) then
+ Pile(Row, Col + 1) := Pile(Row, Col + 1) + 1;
+ end if;
+
+ exit outer;
+ end if;
+ end loop;
+ end loop outer;
+ end Topple;
+
+ ---------
+ -- "+" --
+ ---------
+
+ function "+" (Left, Right : Sandpile) return Sandpile is
+ Result : Sandpile;
+ begin
+ for I in Sandpile'Range(1) loop
+ for J in Sandpile'Range(2) loop
+ Result(I, J) := Left(I, J) + Right(I, J);
+ end loop;
+ end loop;
+ Stabalize(Result);
+ return Result;
+ end "+";
+
+ -----------
+ -- Print --
+ -----------
+
+ procedure Print(Pile : in Sandpile) is
+ begin
+ for row in Pile'Range(1) loop
+ for col in Pile'Range(2) loop
+ Put(Integer'Image(Pile(row, col)));
+ end loop;
+ New_Line;
+ end loop;
+ New_Line;
+ end Print;
+end Abelian_Sandpile;
diff --git a/Task/Abelian-sandpile-model-Identity/Ada/abelian-sandpile-model-identity-3.adb b/Task/Abelian-sandpile-model-Identity/Ada/abelian-sandpile-model-identity-3.adb
new file mode 100644
index 0000000000..350d3736a7
--- /dev/null
+++ b/Task/Abelian-sandpile-model-Identity/Ada/abelian-sandpile-model-identity-3.adb
@@ -0,0 +1,46 @@
+with Ada.Text_IO; use Ada.Text_IO;
+with Abelian_Sandpile; use Abelian_Sandpile;
+
+procedure Main is
+ sp : Sandpile := ((4, 3, 3), (3, 1, 2), (0, 2, 3));
+ s1 : Sandpile := ((1, 2, 0), (2, 1, 1), (0, 1, 3));
+ s2 : Sandpile := ((2, 1, 3), (1, 0, 1), (0, 1, 0));
+ s3 : Sandpile := ((3, 3, 3), (3, 3, 3), (3, 3, 3));
+ s3_id : Sandpile := ((2, 1, 2), (1, 0, 1), (2, 1, 2));
+ sum1 : Sandpile := s1 + s2;
+ sum2 : Sandpile := s2 + s1;
+ sum3 : Sandpile := s3 + s3_id;
+ sum4 : Sandpile := s3_id + s3_id;
+
+begin
+ Put_Line ("Avalanche:");
+ while not Is_Stable (sp) loop
+ Print (sp);
+ Put_Line ("stable? " & Boolean'Image (Is_Stable (sp)));
+ New_Line;
+ Topple (sp);
+ end loop;
+ Print (sp);
+ Put_Line ("stable? " & Boolean'Image (Is_Stable (sp)));
+ New_Line;
+
+ Put_Line ("Commutivity:");
+ Put_Line ("s1 + s2 equals s2 + s2? " & Boolean'Image (sum1 = sum2));
+ New_Line;
+ Put_Line ("S1 : s2 =");
+ Print (sum1);
+ New_Line;
+ Put_Line ("s2 + s1 =");
+ Print (sum2);
+ New_Line;
+
+ Put_Line ("Identity:");
+ Put_Line ("s3 + s3_id equals s3? " & Boolean'Image (sum3 = s3));
+ Put_Line ("s3_id + s3_id equals s3_id? " & Boolean'Image (sum4 = s3_id));
+ New_Line;
+ Put_Line ("s3 + s3_id =");
+ Print (sum3);
+ Put_Line ("s3_id + s3_id =");
+ Print (sum4);
+
+end Main;
diff --git a/Task/Abelian-sandpile-model-Identity/Crystal/abelian-sandpile-model-identity.cr b/Task/Abelian-sandpile-model-Identity/Crystal/abelian-sandpile-model-identity.cr
new file mode 100644
index 0000000000..f768a9132b
--- /dev/null
+++ b/Task/Abelian-sandpile-model-Identity/Crystal/abelian-sandpile-model-identity.cr
@@ -0,0 +1,86 @@
+class Sandpile
+ getter pile : Array(Array(Int32))
+ getter width : Int32
+ getter height : Int32
+
+ def initialize (values : Array(Array(Int32)))
+ @pile = values.map {|row| row.dup }
+ @width = @pile[0].size
+ @height = @pile.size
+ stabilize
+ end
+
+ def initialize (@width, @height)
+ @pile = Array.new(@height) { Array.new(@width, 0) }
+ end
+
+ def stabilize
+ pile, h, w = @pile, @width, @height
+ loop do
+ done = true
+ (0...h).each do |r|
+ (0...w).each do |c|
+ stack = pile[r][c]
+ if stack >= 4
+ portion = stack // 4
+ pile[r][c] %= 4
+ (pile[r][c-1] += portion) if c-1 >= 0
+ (pile[r][c+1] += portion) if c+1 < width
+ (pile[r-1][c] += portion) if r-1 >= 0
+ (pile[r+1][c] += portion) if r+1 < height
+ done = false
+ end
+ end
+ end
+ break if done
+ end
+ @pile = pile
+ self
+ end
+
+ def check_compatible (other)
+ raise "incompatible sandpiles" unless other.height == height &&
+ other.width == width
+ end
+
+ def + (other)
+ check_compatible(other)
+ new_pile = @pile.zip(other.@pile).map {|(row1, row2)|
+ row1.zip(row2).map {|a, b| a + b }
+ }
+ Sandpile.new(new_pile)
+ end
+end
+
+def print_row (items)
+ heights = items.map {|item| item.is_a?(Sandpile) ? item.height : 1 }
+ lines = heights.max
+ (0...lines).each do |i|
+ items.each do |item|
+ if item.is_a?(Sandpile)
+ print item.pile[i].join(" ")
+ elsif i == lines // 2
+ print item
+ else
+ print " "*item.size
+ end
+ end
+ puts
+ end
+end
+
+
+s1 = Sandpile.new([[1,2,0],[2,1,1],[0,1,3]])
+s2 = Sandpile.new([[2,1,3],[1,0,1],[0,1,0]])
+s3 = Sandpile.new([[3,3,3],[3,3,3],[3,3,3]])
+s3_id = Sandpile.new([[2,1,2],[1,0,1],[2,1,2]])
+
+print_row ["s1 + s2 = s2 + s1 = ", s1, " + ", s2, " = ", s1 + s2,
+ " = ", s2, " + ", s1, " = ", s2 + s1]
+
+puts
+print_row ["s3 + s3_id = s3 = ",
+ s3, " + ", s3_id, " = ", s3 + s3_id]
+puts
+print_row ["s3_id + s3_id = s3_id = ",
+ s3_id, " + ", s3_id, " = ", s3_id + s3_id]
diff --git a/Task/Abelian-sandpile-model-Identity/Fortran/abelian-sandpile-model-identity.f b/Task/Abelian-sandpile-model-Identity/Fortran/abelian-sandpile-model-identity.f
new file mode 100644
index 0000000000..158267f648
--- /dev/null
+++ b/Task/Abelian-sandpile-model-Identity/Fortran/abelian-sandpile-model-identity.f
@@ -0,0 +1,223 @@
+!
+! Abelian sandpile model/Identity
+! tested with Intel ifx (IFX) 2025.2.1 20250806 on Kubuntu 25.04
+! GNU Fortran (Ubuntu 14.2.0-19ubuntu2) 14.2.0 on Kubuntu 25.04
+! VSI Fortran x86-64 V8.6-001 on OpenVMS x86_64 V9.2-3
+! No Non-standard features used, should compile on any fairly recent Fortran.
+! U.B., September 2025
+!
+ program Abelian
+ implicit none
+
+ integer :: av (3,3), s1(3,3), s2(3,3), s3(3,3), s3_id(3,3), result1(3,3), result2(3,3)
+
+ av = reshape ( [ & ! Start value for Avalanche
+ 4,3,3, &
+ 3,1,2, &
+ 0,2,3], shape(s3))
+
+ s1 = reshape ( [ & ! S1,s2,s3,s3_id as in task description
+ 1,2,0, &
+ 2,1,1, &
+ 0,1,3], shape(s1))
+ s2 = reshape ( [ &
+ 2,1,3, &
+ 1,0,1, &
+ 0,1,0], shape(s2))
+ s3 = reshape ( [ &
+ 3,3,3, &
+ 3,3,3, &
+ 3,3,3], shape(s3))
+ s3_id = reshape ( [ &
+ 2,1,2, &
+ 1,0,1, &
+ 2,1,2], shape(s3_id))
+
+
+
+ print '("Avalanche: ")'
+ print '("---------- ")'
+
+ call print_it ("Start with ", av)
+ do
+ if (isStable (av)) then
+ print '(A/)', 'is stable.'
+ exit
+ else
+ print '(A/)', 'is not stable.'
+ endif
+ call topple (av)
+ call print_it (" ", s3)
+ end do
+
+
+ print '(///A)', 'Commutivity:'
+ print '(A)', '------------'
+
+ call print_it ('s1 = ', s1)
+ print *
+ call print_it ('s2 = ', s2)
+ print *
+ result1 = add(s1,s2)
+ call print_it ('s1 + s2 = ', result1)
+ print *
+ result2 = add(s2,s1)
+ call print_it ('s2 + s1 = ', result2)
+ print *
+
+ if (isEqual (result1,result2)) then
+ print '(A)', 's1 + s2 = s2 + s1 VERIFIED'
+ else
+ print '(A)', 's1 + s2 = s2 + s1 NOT VERIFIED'
+ endif
+
+ print '(///A)', 'Identity:'
+ print '(A)', '---------'
+
+ call print_it ('s3 = ', s3)
+ print *
+ call print_it ('s3_id = ', s3_ID)
+ print *
+ result1 = add (s3, s3_id)
+ do while ( .not. isstable (result1))
+ call topple (result1)
+ end do
+ call print_it ('s3 + s3_id = ', result1)
+ print *
+ if (isEqual (s3,result1)) then
+ print '(A/)', 's3 + s3_id = s3 VERIFIED'
+ else
+ print '(A/)', 's3 + s3_id = s3 NOT VERIFIED'
+ endif
+
+ result1 = add (s3_id, s3_id)
+ do while ( .not. isstable (result1))
+ call topple (result1)
+ end do
+ call print_it ('s3_id + s3_id = ', result1)
+ print *
+ if (isEqual (s3_id, result1)) then
+ print '(A)', 's3_id + s3_id = s3_id VERIFIED'
+ else
+ print '(A)', 's3_id + s3_id = s3_id NOT VERIFIED'
+ endif
+
+
+
+ contains
+
+
+ ! -----------------------------------
+ ! Check if 2 sand piles are identical
+ ! -----------------------------------
+ function isEqual (a,b) result (r)
+
+ integer, intent(in) :: a(3,3),B(3,3)
+ integer :: ii,jj
+ logical :: r
+
+ r = .false.
+ do ii=1,3
+ do jj=1,3
+ if ( a(ii,jj) .ne. b(ii,jj) ) return
+ end do
+ end do
+ r=.true.
+ end function isEqual
+
+
+ ! ----------------------------------------------------------
+ ! Print sand pile contents, together with a descriptive text
+ ! ----------------------------------------------------------
+ subroutine print_it (text, a)
+
+ integer :: a (3,3)
+
+ character (len=*) :: text
+ character (len=:), allocatable :: blank
+
+ integer :: ii, jj
+
+ ! create blank string with same length as text
+ blank = text
+ do ii=1, len (blank)
+ blank(ii:ii) = ' '
+ end do
+ do jj = 1, 3 ! three lines to print. Note: 2nd index is row, 1st is column
+ if (jj .eq. 2) then ! Description in middle line
+ write (*,'(A)', advance='no') text
+ else
+ write (*,'(A)', advance='no') blank ! empty space to have same indent for the other lines
+ endif
+ do ii=1,3 ! then the 3 columns of this row
+ write (*, '(i1," ")', advance='no') a(ii,jj)
+ end do
+ write (*,*) ! terminate current line
+ end do
+
+ end subroutine print_it
+
+
+ ! --------------------------------
+ ! Add the contents of 2 sand piles
+ ! --------------------------------
+ function add (a,b) result (c)
+
+ integer, intent(in) :: a (3,3),b(3,3)
+ integer ::c(3,3)
+
+ integer :: ii, jj
+ do ii = 1, 3
+ do jj=1,3
+ c(ii,jj) = a(ii,jj) + b(ii,jj)
+ end do
+ end do
+ end function add
+
+
+ ! ----------------------------------------------
+ ! Check if sand pile is stable (all elements <4)
+ ! ----------------------------------------------
+ function isStable (a) result(Yes)
+
+ integer, intent(in) :: a(3,3)
+ logical :: Yes
+ integer :: ii, jj
+
+ yes = .true.
+ do ii = 1, 3
+ do jj=1, 3
+ if (a(ii,jj) .gt.3) then ! >3 means not stable.
+ Yes = .false.
+ return
+ end if
+ end do
+ end do
+ end function isStable
+
+
+ ! ----------------------------------
+ ! 1 cycle of toppling of a sand pile
+ ! ----------------------------------
+ subroutine topple (a)
+ implicit none
+
+ integer, intent(inout) :: a (3,3)
+ logical :: Yes
+ integer :: ii, jj
+
+ do jj = 1, 3 ! row is second index
+ do ii=1,3 ! col is 1st index
+ if (a(ii,jj) .gt.3) then
+ a(ii,jj) = a(ii,jj) - 4
+ if (ii .gt. 1) a(ii-1,jj) = a(ii-1,jj) + 1
+ if (ii .lt. 3) a(ii+1,jj) = a(ii+1,jj) + 1
+ if (jj .gt. 1) a(ii,jj-1) = a(ii,jj-1) + 1
+ if (jj .lt. 3) a(ii,jj+1) = a(ii,jj+1) + 1
+ return
+ end if
+ end do
+ end do
+ end subroutine topple
+
+ end program Abelian
diff --git a/Task/Abelian-sandpile-model-Identity/Rebol/abelian-sandpile-model-identity.rebol b/Task/Abelian-sandpile-model-Identity/Rebol/abelian-sandpile-model-identity.rebol
new file mode 100644
index 0000000000..f3014baa6e
--- /dev/null
+++ b/Task/Abelian-sandpile-model-Identity/Rebol/abelian-sandpile-model-identity.rebol
@@ -0,0 +1,105 @@
+Rebol [
+ title: "Rosetta code: Abelian sandpile model/Identity"
+ file: %Abelian_sandpile_model-Identitys.r3
+ url: https://rosettacode.org/wiki/Abelian_sandpile_model/Identity
+ note: "Based on Red language solution"
+]
+sadd: context [
+ ;; 'comb' adds two 3x3 piles cell by cell, then validates the result
+ comb: function [pile1 [series!] pile2 [series!]] [
+ ;; Loop over rows 1 to 3
+ repeat r 3 [
+ ;; Loop over columns 1 to 3
+ repeat c 3 [
+ ;; Add corresponding cell values from pile1 to pile2
+ pile2/:r/:c: pile2/:r/:c + pile1/:r/:c
+ ]
+ ]
+ ;; Validate and stabilize the resulting pile
+ check pile2
+ ]
+ ;; 'check' ensures no cell exceeds threshold (4); if it does, it topples
+ check: function [pile [series!]] [
+ stable: true ;; Flag to track if pile is stable
+ row: col: none ;; Coordinates of any unstable cell
+ ;; Scan the 3x3 grid for cells >= 4
+ repeat r 3 [
+ repeat c 3 [
+ if pile/:r/:c >= 4 [
+ stable: false
+ ;; Subtract threshold from the unstable cell
+ pile/:r/:c: pile/:r/:c - 4
+ row: r col: c
+ break ;; Exit inner repeat when found
+ ]
+ ]
+ unless stable [break] ;; Exit outer repeat if unstable cell found
+ ]
+ ;; If no unstable cell was found, print final pile and exit
+ if stable [
+ print trim/with mold/only pile "[]"
+ print ""
+ exit
+ ]
+ ;; Distribute ("spill") grains from the unstable cell to neighbors
+ spill pile row col
+ ]
+ ;; 'spill' distributes one grain to each valid neighbor of (r, c)
+ spill: function [pile [series!] r [integer!] c [integer!]] [
+ ;; Define neighbor offsets: right, up, left, down
+ neigh: reduce [
+ right: reduce [r c - 1]
+ up: reduce [r + 1 c]
+ left: reduce [r c + 1]
+ down: reduce [r - 1 c]
+ ]
+ ;; For each neighbor coordinate pair 'n'
+ foreach n neigh [
+ ;; If neighbor cell exists (not off-grid), add one grain
+ unless any [
+ none? pile/(n/1)
+ none? pile/(n/1)/(n/2)
+ ][
+ pile/(n/1)/(n/2): pile/(n/1)/(n/2) + 1
+ ]
+ ]
+ ;; Re-check pile for further toppling
+ check pile
+ ]
+]
+
+s1: [
+ [1 2 0]
+ [2 1 1]
+ [0 1 3]
+]
+s2: [
+ [2 1 3]
+ [1 0 1]
+ [0 1 0]
+]
+s3: [
+ [3 3 3]
+ [3 3 3]
+ [3 3 3]
+]
+s3_id: [
+ [2 1 2]
+ [1 0 1]
+ [2 1 2]
+]
+ex: [
+ [4 3 3]
+ [3 1 2]
+ [0 2 3]
+]
+print "Avalanche of topplings"
+sadd/check copy/deep ex
+print "Add s1 to s2"
+sadd/comb copy/deep s1 copy/deep s2
+print "Add s2 to s1"
+sadd/comb copy/deep s2 copy/deep s1
+print "Add s3 to s3_id"
+sadd/comb copy/deep s3 copy/deep s3_id
+print "Add s3_id to s3_id"
+sadd/comb copy/deep s3_id copy/deep s3_id
diff --git a/Task/Abelian-sandpile-model/APL/abelian-sandpile-model-1.apl b/Task/Abelian-sandpile-model/APL/abelian-sandpile-model-1.apl
new file mode 100644
index 0000000000..7c007133c3
--- /dev/null
+++ b/Task/Abelian-sandpile-model/APL/abelian-sandpile-model-1.apl
@@ -0,0 +1,12 @@
+⍝ Collapse a sandpile in a given matrix
+sandpile←{⍵-(4×S)-⊃+/(1 ¯1⊖¨⊂S)+1 ¯1⌽¨⊂S←⍵≥4}⍣≡
+
+⍝ An ⍺-by-⍺ matrix with its middle element set to ⍵
+middle←{⍺ ⍺↑(-⌈⍺ ⍺÷2)↑⍵}
+
+⍝ Write the sandpile in ⍵ as a PPM image to file ⍺
+to_ppm←{
+ colors←'0 0 0' '0 1 0' '1 0 1' '1 1 0'
+ ppm←∊⎕TC[2],⍨¨'P3'(⍕⍴⍵)(,⊂'1'),colors[1+,⍵]
+ (⊂ppm)⎕NPUT⍺
+}
diff --git a/Task/Abelian-sandpile-model/APL/abelian-sandpile-model-2.apl b/Task/Abelian-sandpile-model/APL/abelian-sandpile-model-2.apl
new file mode 100644
index 0000000000..fbda092c12
--- /dev/null
+++ b/Task/Abelian-sandpile-model/APL/abelian-sandpile-model-2.apl
@@ -0,0 +1,14 @@
+ ⍝ Result of collapsing '64'
+ sandpile 9 middle 64
+0 0 0 0 0 0 0 0 0
+0 0 0 1 2 1 0 0 0
+0 0 2 2 2 2 2 0 0
+0 1 2 2 2 2 2 1 0
+0 2 2 2 0 2 2 2 0
+0 1 2 2 2 2 2 1 0
+0 0 2 2 2 2 2 0 0
+0 0 0 1 2 1 0 0 0
+0 0 0 0 0 0 0 0 0
+
+ ⍝ Write image of result of collapsing 22000
+ 'sandpile.ppm' to_ppm sandpile 121 middle 22000
diff --git a/Task/Abelian-sandpile-model/Ada/abelian-sandpile-model.adb b/Task/Abelian-sandpile-model/Ada/abelian-sandpile-model.adb
new file mode 100644
index 0000000000..10aa915326
--- /dev/null
+++ b/Task/Abelian-sandpile-model/Ada/abelian-sandpile-model.adb
@@ -0,0 +1,67 @@
+pragma Ada_2022;
+with Ada.Command_Line; use Ada.Command_Line;
+with Ada.Text_IO; use Ada.Text_IO;
+procedure Abelian_Sandpile is
+ type Grid_2D is array (Positive range <>, Positive range <>) of Natural;
+
+ procedure Write_PPM (Grid : Grid_2D; Filename : String) is
+ PPM_File : File_Type;
+ begin
+ Create (PPM_File, Out_File, Filename);
+ Put_Line (PPM_File, "P3");
+ Put_Line (PPM_File, Grid'Length (1)'Image & Grid'Length (2)'Image);
+ Put_Line (PPM_File, "7");
+ for Y in 1 .. Grid'Length (2) loop
+ for X in 1 .. Grid'Length (1) loop
+ case Grid (X, Y) is
+ when 0 => Put_Line (PPM_File, "0 0 0"); -- black
+ when 1 => Put_Line (PPM_File, "0 7 0"); -- green
+ when 2 => Put_Line (PPM_File, "7 0 7"); -- lilac
+ when 3 => Put_Line (PPM_File, "7 7 0"); -- yellow
+ when others => Put_Line (PPM_File, "0 0 7"); -- blue, shouldn't happen
+ end case;
+ end loop;
+ end loop;
+ Close (PPM_File);
+ end Write_PPM;
+begin
+ if Argument_Count /= 2 then
+ Put_Line ("Error: Must specify ");
+ else
+ declare
+ Initial_Height : constant Positive := Positive'Value (Argument (1));
+ Grid_Size : constant Positive := Positive'Value (Argument (2));
+ Sandpile : Grid_2D (1 .. Grid_Size, 1 .. Grid_Size) := [others => [others => 0]];
+ More_To_Do : Boolean := True;
+ Overspill : Natural;
+ begin
+ Sandpile (Grid_Size / 2, Grid_Size / 2) := Initial_Height;
+ while More_To_Do loop
+ More_To_Do := False;
+ for X in 1 .. Grid_Size loop
+ for Y in 1 .. Grid_Size loop
+ if Sandpile (X, Y) >= 4 then
+ Overspill := Sandpile (X, Y) / 4;
+ Sandpile (X, Y) := @ mod 4;
+ More_To_Do := True;
+ if X > 1 then
+ Sandpile (X - 1, Y) := @ + Overspill;
+ end if;
+ if Y > 1 then
+ Sandpile (X, Y - 1) := @ + Overspill;
+ end if;
+ if X < Grid_Size then
+ Sandpile (X + 1, Y) := @ + Overspill;
+ end if;
+ if Y < Grid_Size then
+ Sandpile (X, Y + 1) := @ + Overspill;
+ end if;
+ end if;
+ end loop;
+ end loop;
+ end loop;
+ if Grid_Size < 16 then Put_Line (Sandpile'Image); end if;
+ Write_PPM (Sandpile, "sandpile.ppm");
+ end;
+ end if;
+end Abelian_Sandpile;
diff --git a/Task/Abelian-sandpile-model/Crystal/abelian-sandpile-model.cr b/Task/Abelian-sandpile-model/Crystal/abelian-sandpile-model.cr
new file mode 100644
index 0000000000..f09cfac038
--- /dev/null
+++ b/Task/Abelian-sandpile-model/Crystal/abelian-sandpile-model.cr
@@ -0,0 +1,76 @@
+def abelian_sandpile (width, height, stacks)
+ pile = Array(Array(Int32)).new(height) { Array(Int32).new(width, 0) }
+ minr = maxr = height // 2
+ minc = maxc = width // 2
+ stacks.each do |(c, r), stack|
+ pile[r][c] = stack
+ minc = c if c < minc
+ maxc = c if c > maxc
+ minr = r if r < minr
+ maxr = r if r > maxr
+ end
+ loop do
+ done = true
+ (minr .. maxr).each do |r|
+ (minc .. maxc).each do |c|
+ stack = pile[r][c]
+ if stack >= 4
+ portion = stack // 4
+ pile[r][c] %= 4
+ (pile[r][c-1] += portion) && (minc = Math.min(minc, c-1)) if c-1 >= 0
+ (pile[r][c+1] += portion) && (maxc = Math.max(maxc, c+1)) if c+1 < width
+ (pile[r-1][c] += portion) && (minr = Math.min(minr, r-1)) if r-1 >= 0
+ (pile[r+1][c] += portion) && (maxr = Math.max(maxr, r+1)) if r+1 < height
+ done = false
+ end
+ end
+ end
+ break if done
+ end
+ pile
+end
+
+def write_sandpile_to_ppm (name, pile, palette = [0, 0x73AAF9, 0xFFC000, 0x7C0000])
+ File.open(name, "w") do |f|
+ f.print "P6\n#{pile[0].size} #{pile.size} 255"
+ f.write_byte 10
+ pile.each do |row|
+ row.each do |stack|
+ color = palette[stack]
+ f.write_byte (color >> 16 & 0xff).to_u8 # red
+ f.write_byte (color >> 8 & 0xff).to_u8 # green
+ f.write_byte (color & 0xff).to_u8 # blue
+ end
+ end
+ end
+end
+
+def usage
+ STDERR.puts "Usage: #$0 filename width height x y stacksize [x y stacksize ...]"
+ STDERR.puts " or: #$0 filename stacksize"
+ exit
+end
+
+filename = ""
+width = height = 0
+stacks = [] of { {Int32, Int32}, Int32 }
+
+begin
+ filename = ARGV.shift
+ if ARGV.size == 1
+ stacksize = ARGV.shift.to_i
+ size = Math.sqrt(stacksize / 1.75).to_i + 3
+ size += 1 unless size.odd?
+ height = width = size
+ stacks << { { size // 2, size // 2 }, stacksize }
+ else
+ width, height = ARGV.shift.to_i, ARGV.shift.to_i
+ ARGV.each_slice(3) do |slice|
+ stacks << { { slice[0].to_i, slice[1].to_i }, slice[2].to_i }
+ end
+ end
+rescue
+ usage
+end
+
+write_sandpile_to_ppm filename, abelian_sandpile(width, height, stacks)
diff --git a/Task/Abelian-sandpile-model/Uiua/abelian-sandpile-model.uiua b/Task/Abelian-sandpile-model/Uiua/abelian-sandpile-model.uiua
index bff94f44fb..73c63c9302 100644
--- a/Task/Abelian-sandpile-model/Uiua/abelian-sandpile-model.uiua
+++ b/Task/Abelian-sandpile-model/Uiua/abelian-sandpile-model.uiua
@@ -1,10 +1,16 @@
-G ← ⍜⊡⋅6000⌊÷2⟜↯⊟.71 0 # good demo
+# Experimental!
+G ← ⍜⊡⋅6000⌊÷2⟜↯˙⊟71 0 # good demo
PadTL ← ↻¯≡↥0⊙⬚°◌↙⟜(+⌵)⊙⊸△
# Pad the differences grid to same size, making ops *much* faster.
-D ← ⬚0PadTL-△G △.[0_1_0 1_¯4_1 0_1_0]
-Scale ← ▽⟜≡▽4÷/↥/↥. # Greyscale and upscale for output.
-Abelian₁ ← ∧(+(↻¯:D))≡(-1_1)⊚≥4.⊙(+1) # Moves grains one at a time
-Abelian₄ ← ∧(+×⊃(⌊÷4⊡+1_1|↻¯:D)⊙.)≡(-1_1)⊚≥4.⊙(+1) # Moves all >= 4 -- slightly faster
-⟜Scale&p⍜now⍥Abelian₄ 100G 0
-⟜Scale&p⍜now⍥Abelian₄ 900⊙,
-Scale⍥Abelian₄∞⊙, # Run to completion
+D ← ⬚0PadTL-△G⊸△[0_1_0 1_¯4_1 0_1_0]
+Scale ← ▽⟜≡▽4÷/↥⊸/↥ # Greyscale and upscale for output.
+Abelian₁ ← ∧(+(↻˜¯D))≡(-1_1)⊚⊸≥4⊙(+1) # Moves grains one at a time
+Abelian₄ ← ∧(+×⊃(⌊÷4⊡+1_1|↻˜¯D)⊃⊙∘⋅∘)≡(-1_1)⊚⊸≥4⊙+₁ # Moves all >= 4 -- slightly faster
+A ← (≡Scale↘200⍥(⤚Abelian₄)600G 0)
+B ← (
+ ⟜Scale&p⍜now⍥Abelian₄ 100G 0
+ ⟜Scale&p⍜now⍥Abelian₄ 900⊃⊙⋅∘⋅⊙∘
+ Scale⍥Abelian₄∞⊃⊙⋅∘⋅⊙∘ # Run to completion
+)
+# Choose A or B
+A
diff --git a/Task/Abstract-type/00-TASK.txt b/Task/Abstract-type/00-TASK.txt
index 12c67b0c1a..bc11ecc714 100644
--- a/Task/Abstract-type/00-TASK.txt
+++ b/Task/Abstract-type/00-TASK.txt
@@ -1,6 +1,6 @@
'''Abstract type''' is a type without instances or without definition.
-For example in [[object-oriented programming]] using some languages, abstract types can be partial implementations of other types, which are to be derived there-from. An abstract type may provide implementation of some operations and/or components. Abstract types without any implementation are called '''interfaces'''. In the languages that do not support multiple [[inheritance]] ([[Ada]], [[Java]]), classes can, nonetheless, inherit from multiple interfaces. The languages with multiple inheritance (like [[C++]]) usually make no distinction between partially implementable abstract types and interfaces. Because the abstract type's implementation is incomplete, [[object-oriented programming | OO]] languages normally prevent instantiation from them (instantiation must derived from one of their descendant classes).
+For example in [[object-oriented programming]] using some languages, abstract types can be partial implementations of other types, which are to be derived there-from. An abstract type may provide implementation of some operations and/or components. Abstract types without any implementation are called [[wp:Interface_(object-oriented_programming)|'''interfaces''']]. In the languages that do not support multiple [[inheritance]] ([[Ada]], [[Java]]), classes can, nonetheless, inherit from multiple interfaces. The languages with multiple inheritance (like [[C++]]) usually make no distinction between partially implementable abstract types and interfaces. Because the abstract type's implementation is incomplete, [[object-oriented programming | OO]] languages normally prevent instantiation from them (instantiation must derived from one of their descendant classes).
The term '''abstract datatype''' also may denote a type, with an implementation provided by the programmer rather than directly by the language (a '''built-in''' or an inferred type). Here the word ''abstract'' means that the implementation is abstracted away, irrelevant for the user of the type. Such implementation can and should be hidden if the language supports separation of implementation and specification. This hides complexity while allowing the implementation to change without repercussions on the usage. The corresponding software design practice is said to follow the [[wp:Information_hiding|information hiding principle]].
diff --git a/Task/Abstract-type/Ada/abstract-type-1.adb b/Task/Abstract-type/Ada/abstract-type-1.adb
new file mode 100644
index 0000000000..ec6e7dfe56
--- /dev/null
+++ b/Task/Abstract-type/Ada/abstract-type-1.adb
@@ -0,0 +1,3 @@
+type Queue is limited interface;
+procedure Enqueue (Lounge : in out Queue; Item : in out Element) is abstract;
+procedure Dequeue (Lounge : in out Queue; Item : in out Element) is abstract;
diff --git a/Task/Abstract-type/Ada/abstract-type-2.adb b/Task/Abstract-type/Ada/abstract-type-2.adb
new file mode 100644
index 0000000000..09512a4fd8
--- /dev/null
+++ b/Task/Abstract-type/Ada/abstract-type-2.adb
@@ -0,0 +1,2 @@
+type Scheduler is task interface;
+procedure Plan (Manager : in out Scheduler; Activity : in out Job) is abstract;
diff --git a/Task/Abstract-type/Ada/abstract-type-3.adb b/Task/Abstract-type/Ada/abstract-type-3.adb
new file mode 100644
index 0000000000..712648f9b7
--- /dev/null
+++ b/Task/Abstract-type/Ada/abstract-type-3.adb
@@ -0,0 +1,10 @@
+with Ada.Finalization;
+...
+type Node is abstract new Ada.Finalization.Limited_Controlled and Queue with record
+ Previous : not null access Node'Class := Node'Unchecked_Access;
+ Next : not null access Node'Class := Node'Unchecked_Access;
+end record;
+overriding procedure Finalize (X : in out Node); -- Removes the node from its list if any
+overriding procedure Dequeue (Lounge : in out Node; Item : in out Element);
+overriding procedure Enqueue (Lounge : in out Node; Item : in out Element);
+procedure Process (X : in out Node) is abstract; -- To be implemented
diff --git a/Task/Abstract-type/COBOL/abstract-type.cob b/Task/Abstract-type/COBOL/abstract-type.cob
new file mode 100644
index 0000000000..3010951b3c
--- /dev/null
+++ b/Task/Abstract-type/COBOL/abstract-type.cob
@@ -0,0 +1,68 @@
+ IDENTIFICATION DIVISION.
+ INTERFACE-ID. Shape.
+
+ PROCEDURE DIVISION.
+
+ IDENTIFICATION DIVISION.
+ METHOD-ID. perimeter.
+ DATA DIVISION.
+ LINKAGE SECTION.
+ 01 ret USAGE FLOAT-LONG.
+ PROCEDURE DIVISION RETURNING ret.
+ END METHOD perimeter.
+
+ IDENTIFICATION DIVISION.
+ METHOD-ID. shape-area.
+ DATA DIVISION.
+ LINKAGE SECTION.
+ 01 ret USAGE FLOAT-LONG.
+ PROCEDURE DIVISION RETURNING ret.
+ END METHOD shape-area.
+
+ END INTERFACE Shape.
+
+
+ IDENTIFICATION DIVISION.
+ CLASS-ID. Rectangle.
+
+ ENVIRONMENT DIVISION.
+ CONFIGURATION SECTION.
+ REPOSITORY.
+ INTERFACE Shape.
+
+ IDENTIFICATION DIVISION.
+ OBJECT IMPLEMENTS Shape.
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 width USAGE FLOAT-LONG PROPERTY.
+ 01 height USAGE FLOAT-LONG PROPERTY.
+
+ PROCEDURE DIVISION.
+
+ IDENTIFICATION DIVISION.
+ METHOD-ID. perimeter.
+ DATA DIVISION.
+ LINKAGE SECTION.
+ 01 ret USAGE FLOAT-LONG.
+ PROCEDURE DIVISION RETURNING ret.
+ COMPUTE
+ ret = width * 2.0 + height * 2.0
+ END-COMPUTE
+ GOBACK.
+ END METHOD perimeter.
+
+ IDENTIFICATION DIVISION.
+ METHOD-ID. shape-area.
+ DATA DIVISION.
+ LINKAGE SECTION.
+ 01 ret USAGE FLOAT-LONG.
+ PROCEDURE DIVISION RETURNING ret.
+ COMPUTE
+ ret = width * height
+ END-COMPUTE
+ GOBACK.
+ END METHOD shape-area.
+
+ END OBJECT.
+
+ END CLASS Rectangle.
diff --git a/Task/Abstract-type/Gleam/abstract-type.gleam b/Task/Abstract-type/Gleam/abstract-type.gleam
new file mode 100644
index 0000000000..df8cda4c81
--- /dev/null
+++ b/Task/Abstract-type/Gleam/abstract-type.gleam
@@ -0,0 +1,24 @@
+pub fn main() {
+ let positive = new(1)
+ let zero = new(0)
+ let negative = new(-1)
+
+ echo to_int(positive)
+ echo to_int(zero)
+ echo to_int(negative)
+}
+
+pub opaque type PositiveInt {
+ PositiveInt(inner: Int)
+}
+
+pub fn new(i: Int) -> PositiveInt {
+ case i >= 0 {
+ True -> PositiveInt(i)
+ False -> PositiveInt(0)
+ }
+}
+
+pub fn to_int(i: PositiveInt) -> Int {
+ i.inner
+}
diff --git a/Task/Abstract-type/Haxe/abstract-type-1.hx b/Task/Abstract-type/Haxe/abstract-type-1.hx
new file mode 100644
index 0000000000..91134488e5
--- /dev/null
+++ b/Task/Abstract-type/Haxe/abstract-type-1.hx
@@ -0,0 +1,44 @@
+interface Vocal {
+ public function speak():String;
+}
+
+interface Gravitational {
+ public function getWeight():Int;
+}
+
+abstract class Dog implements Vocal implements Gravitational {
+ public function speak():String {
+ return "Woof";
+ }
+
+ public function new() {}
+}
+
+class Chihuahua extends Dog {
+ public function getWeight():Int {
+ return 5;
+ }
+}
+
+class GreatDane extends Dog {
+ public function getWeight():Int {
+ return 150;
+ }
+}
+
+class Main {
+ static public function main():Void {
+ var dogs:Array = [];
+
+ var david = new Chihuahua();
+ var goliath = new GreatDane();
+
+ dogs.push(david);
+ dogs.push(goliath);
+
+ for (dog in dogs) {
+ trace(dog.speak());
+ trace(dog.getWeight());
+ }
+ }
+}
diff --git a/Task/Abstract-type/Haxe/abstract-type-2.hx b/Task/Abstract-type/Haxe/abstract-type-2.hx
new file mode 100644
index 0000000000..7745ff6089
--- /dev/null
+++ b/Task/Abstract-type/Haxe/abstract-type-2.hx
@@ -0,0 +1,3 @@
+class abstraction()
+ abstract method compare(l,r) # generates runerr(700, "method compare()")
+end
diff --git a/Task/Abstract-type/PowerShell/abstract-type-1.ps1 b/Task/Abstract-type/PowerShell/abstract-type-1.ps1
new file mode 100644
index 0000000000..c1c82d3b36
--- /dev/null
+++ b/Task/Abstract-type/PowerShell/abstract-type-1.ps1
@@ -0,0 +1,92 @@
+#Requires -Version 5.0
+
+Class Player
+{
+ <#
+ Properties: Name, Team, Position and Number
+ #>
+ [string]$Name
+
+ [ValidateSet("Baltimore Ravens","Cincinnati Bengals","Cleveland Browns","Pittsburgh Steelers",
+ "Chicago Bears","Detroit Lions","Green Bay Packers","Minnesota Vikings",
+ "Houston Texans","Indianapolis Colts","Jacksonville Jaguars","Tennessee Titans",
+ "Atlanta Falcons","Carolina Panthers","New Orleans Saints","Tampa Bay Buccaneers",
+ "Buffalo Bills","Miami Dolphins","New England Patriots","New York Jets",
+ "Dallas Cowboys","New York Giants","Philadelphia Eagles","Washington Redskins",
+ "Denver Broncos","Kansas City Chiefs","Oakland Raiders","San Diego Chargers",
+ "Arizona Cardinals","Los Angeles Rams","San Francisco 49ers","Seattle Seahawks")]
+ [string]$Team
+
+ [ValidateSet("C","G","T","QB","RB","WR","TE","DT","DE","ILB","OLB","CB","S","K","H","LS","P","KOS","R")]
+ [string]$Position
+
+ [ValidateRange(0,99)]
+ [int]$Number
+
+ <#
+ Constructor: Creates a new Player object, with the specified Name, Team, Position and Number.
+ #>
+ Player([string]$Name, [string]$Team, [string]$Position, [int]$Number)
+ {
+ $this.Name = (Get-Culture).TextInfo.ToTitleCase("$Name")
+ $this.Team = (Get-Culture).TextInfo.ToTitleCase("$Team")
+ $this.Position = $Position.ToUpper()
+ $this.Number = $Number
+ }
+
+ <#
+ Methods: Trade the player to a different team (optional parameters for methods in PowerShell 5 classes are not available. Boo!!)
+ An overloaded method is a method with the same name as another method but in a different context,
+ in this case with different parameters.
+ #>
+ Trade([string]$NewTeam)
+ {
+ [string[]]$league = "Baltimore Ravens","Cincinnati Bengals","Cleveland Browns","Pittsburgh Steelers",
+ "Chicago Bears","Detroit Lions","Green Bay Packers","Minnesota Vikings",
+ "Houston Texans","Indianapolis Colts","Jacksonville Jaguars","Tennessee Titans",
+ "Atlanta Falcons","Carolina Panthers","New Orleans Saints","Tampa Bay Buccaneers",
+ "Buffalo Bills","Miami Dolphins","New England Patriots","New York Jets",
+ "Dallas Cowboys","New York Giants","Philadelphia Eagles","Washington Redskins",
+ "Denver Broncos","Kansas City Chiefs","Oakland Raiders","San Diego Chargers",
+ "Arizona Cardinals","Los Angeles Rams","San Francisco 49ers","Seattle Seahawks"
+
+ if ($NewTeam -in $league | Where-Object {$_ -notmatch $this.Team})
+ {
+ $this.Team = (Get-Culture).TextInfo.ToTitleCase("$NewTeam")
+ }
+ else
+ {
+ throw "Invalid Team"
+ }
+ }
+
+ Trade([string]$NewTeam, [int]$NewNumber)
+ {
+ [string[]]$league = "Baltimore Ravens","Cincinnati Bengals","Cleveland Browns","Pittsburgh Steelers",
+ "Chicago Bears","Detroit Lions","Green Bay Packers","Minnesota Vikings",
+ "Houston Texans","Indianapolis Colts","Jacksonville Jaguars","Tennessee Titans",
+ "Atlanta Falcons","Carolina Panthers","New Orleans Saints","Tampa Bay Buccaneers",
+ "Buffalo Bills","Miami Dolphins","New England Patriots","New York Jets",
+ "Dallas Cowboys","New York Giants","Philadelphia Eagles","Washington Redskins",
+ "Denver Broncos","Kansas City Chiefs","Oakland Raiders","San Diego Chargers",
+ "Arizona Cardinals","Los Angeles Rams","San Francisco 49ers","Seattle Seahawks"
+
+ if ($NewTeam -in $league | Where-Object {$_ -notmatch $this.Team})
+ {
+ $this.Team = (Get-Culture).TextInfo.ToTitleCase("$NewTeam")
+ }
+ else
+ {
+ throw "Invalid Team"
+ }
+
+ if ($NewNumber -in 0..99)
+ {
+ $this.Number = $NewNumber
+ }
+ else
+ {
+ throw "Invalid Number"
+ }
+ }
+}
diff --git a/Task/Abstract-type/PowerShell/abstract-type-2.ps1 b/Task/Abstract-type/PowerShell/abstract-type-2.ps1
new file mode 100644
index 0000000000..a0711e85f9
--- /dev/null
+++ b/Task/Abstract-type/PowerShell/abstract-type-2.ps1
@@ -0,0 +1,2 @@
+$player1 = [Player]::new("sam bradford", "philadelphia eagles", "qb", 7)
+$player1
diff --git a/Task/Abstract-type/PowerShell/abstract-type-3.ps1 b/Task/Abstract-type/PowerShell/abstract-type-3.ps1
new file mode 100644
index 0000000000..4c2ddc606c
--- /dev/null
+++ b/Task/Abstract-type/PowerShell/abstract-type-3.ps1
@@ -0,0 +1,2 @@
+$player1.Trade("minnesota vikings", 8)
+$player1
diff --git a/Task/Abstract-type/PowerShell/abstract-type-4.ps1 b/Task/Abstract-type/PowerShell/abstract-type-4.ps1
new file mode 100644
index 0000000000..7cd5678d1b
--- /dev/null
+++ b/Task/Abstract-type/PowerShell/abstract-type-4.ps1
@@ -0,0 +1,2 @@
+$player2 = [Player]::new("demarco murray", "philadelphia eagles", "rb", 29)
+$player2
diff --git a/Task/Abstract-type/PowerShell/abstract-type-5.ps1 b/Task/Abstract-type/PowerShell/abstract-type-5.ps1
new file mode 100644
index 0000000000..1b65e884e8
--- /dev/null
+++ b/Task/Abstract-type/PowerShell/abstract-type-5.ps1
@@ -0,0 +1,2 @@
+$player2.Trade("tennessee titans")
+$player2
diff --git a/Task/Abstract-type/Python/abstract-type-1.py b/Task/Abstract-type/Python/abstract-type-1.py
index 97bcd27dd4..0d3279e755 100644
--- a/Task/Abstract-type/Python/abstract-type-1.py
+++ b/Task/Abstract-type/Python/abstract-type-1.py
@@ -1,13 +1,33 @@
-class BaseQueue(object):
- """Abstract/Virtual Class
- """
- def __init__(self):
- self.contents = list()
- raise NotImplementedError
- def Enqueue(self, item):
- raise NotImplementedError
- def Dequeue(self):
- raise NotImplementedError
- def Print_Contents(self):
- for i in self.contents:
- print i,
+from abc import ABC
+from abc import abstractmethod
+from typing import Literal
+
+class Pet(ABC):
+ def __init__(self, name: str) -> None:
+ self.name = name
+
+ @abstractmethod
+ def speak(self) -> str: ...
+
+class Cat(Pet):
+ def speak(self) -> str:
+ return f"{self.name} says meow"
+
+class Dog(Pet):
+ def __init__(self, name: str, size: Literal["small", "big"] = "small") -> None:
+ super().__init__(name)
+ self.size = size
+
+ def speak(self) -> str:
+ return "woof" if self.size == "small" else "loud woof"
+
+
+if __name__ == "__main__":
+ pets: list[Pet] = [
+ Cat(name="Fluffy"),
+ Dog(name="Gary"),
+ Dog(name="Sue", size="big"),
+ ]
+
+ for pet in pets:
+ print(pet.speak())
diff --git a/Task/Abstract-type/Python/abstract-type-2.py b/Task/Abstract-type/Python/abstract-type-2.py
index d7e1b0f7eb..5f803fcc7e 100644
--- a/Task/Abstract-type/Python/abstract-type-2.py
+++ b/Task/Abstract-type/Python/abstract-type-2.py
@@ -1,21 +1,31 @@
-from abc import ABCMeta, abstractmethod
+from typing import Literal
+from typing import Protocol
-class BaseQueue():
- """Abstract Class
- """
- __metaclass__ = ABCMeta
+class Pet(Protocol):
+ def speak(self) -> str: ...
- def __init__(self):
- self.contents = list()
+class Cat:
+ def __init__(self, name: str) -> None:
+ self.name = name
- @abstractmethod
- def Enqueue(self, item):
- pass
+ def speak(self) -> str:
+ return f"{self.name} says meow"
- @abstractmethod
- def Dequeue(self):
- pass
+class Dog:
+ def __init__(self, name: str, size: Literal["small", "big"] = "small") -> None:
+ self.name = name
+ self.size = size
- def Print_Contents(self):
- for i in self.contents:
- print i,
+ def speak(self) -> str:
+ return "woof" if self.size == "small" else "loud woof"
+
+
+if __name__ == "__main__":
+ pets: list[Pet] = [
+ Cat(name="Fluffy"),
+ Dog(name="Gary"),
+ Dog(name="Sue", size="big"),
+ ]
+
+ for pet in pets:
+ print(pet.speak())
diff --git a/Task/Abstract-type/ReScript/abstract-type.res b/Task/Abstract-type/ReScript/abstract-type.res
new file mode 100644
index 0000000000..63c57c4e0c
--- /dev/null
+++ b/Task/Abstract-type/ReScript/abstract-type.res
@@ -0,0 +1 @@
+type t
diff --git a/Task/Abstract-type/Rebol/abstract-type.rebol b/Task/Abstract-type/Rebol/abstract-type.rebol
new file mode 100644
index 0000000000..184d2223f1
--- /dev/null
+++ b/Task/Abstract-type/Rebol/abstract-type.rebol
@@ -0,0 +1,44 @@
+REBOL [
+ Title: "Abstract Type"
+ URL: http://rosettacode.org/wiki/Abstract_type
+]
+
+; The "shape" class is an abstract class -- it defines the "pen"
+; property and "line" method, but "size" and "draw" are undefined and
+; unimplemented.
+
+shape: make object! [
+ pen: "X"
+ size: none
+
+ line: func [count][loop count [prin self/pen] prin crlf]
+ draw: does [none]
+]
+
+; The "box" class inherits from "shape" and provides the missing
+; information for drawing boxes.
+
+box: make shape [
+ size: 10
+ draw: does [loop self/size [line self/size]]
+]
+
+; "rectangle" also inherits from "shape", but handles the
+; implementation very differently.
+
+rectangle: make shape [
+ size: 20x10
+ draw: does [loop self/size/y [line self/size/x]]
+]
+
+; Unlike some languages discussed, REBOL has absolutely no qualms
+; about instantiating an "abstract" class -- that's how I created the
+; derived classes of "rectangle" and "box", after all.
+
+s: make shape [] s/draw ; Nothing happens.
+
+print "A box:"
+b: make box [pen: "O" size: 5] b/draw
+
+print "^/A rectangle:"
+r: make rectangle [size: 32x5] r/draw
diff --git a/Task/Abundant-deficient-and-perfect-number-classifications/ANSI-BASIC/abundant-deficient-and-perfect-number-classifications.basic b/Task/Abundant-deficient-and-perfect-number-classifications/ANSI-BASIC/abundant-deficient-and-perfect-number-classifications.basic
new file mode 100644
index 0000000000..90cade1723
--- /dev/null
+++ b/Task/Abundant-deficient-and-perfect-number-classifications/ANSI-BASIC/abundant-deficient-and-perfect-number-classifications.basic
@@ -0,0 +1,34 @@
+100 REM Abundant, deficient and perfect number classifications
+110 DIM Pds(1 TO 20000)
+120 LET MaxNumber = UBOUND(Pds)
+130 LET ACount = 0
+140 LET DCount = 0
+150 LET PCount = 0
+160 LET Pds(1) = 0
+170 FOR I = 2 TO MaxNumber
+180 LET Pds(I) = 1
+190 NEXT I
+200 FOR I = 2 TO MaxNumber
+210 FOR J = I + I TO MaxNumber STEP I
+220 LET Pds(J) = Pds(J) + I
+230 NEXT J
+240 NEXT I
+250 REM Classify the numbers
+260 FOR I = 1 TO MaxNumber
+270 LET DSum = Pds(I)
+280 IF DSum > I THEN
+290 LET ACount = ACount + 1
+300 ELSEIF DSum < I THEN
+310 LET DCount = DCount + 1
+320 ELSE
+330 LET PCount = PCount + 1
+340 END IF
+350 NEXT I
+360 PRINT "Up to"; MaxNumber
+370 PRINT "Number of abundants :";
+380 PRINT USING "######": ACount
+390 PRINT "Number of perfects :";
+400 PRINT USING "######": PCount
+410 PRINT "Number of deficients:";
+420 PRINT USING "######": DCount
+430 END
diff --git a/Task/Abundant-deficient-and-perfect-number-classifications/Ada/abundant-deficient-and-perfect-number-classifications.adb b/Task/Abundant-deficient-and-perfect-number-classifications/Ada/abundant-deficient-and-perfect-number-classifications.adb
new file mode 100644
index 0000000000..6f066bde65
--- /dev/null
+++ b/Task/Abundant-deficient-and-perfect-number-classifications/Ada/abundant-deficient-and-perfect-number-classifications.adb
@@ -0,0 +1,35 @@
+with Ada.Text_IO, Generic_Divisors;
+
+procedure ADB_Classification is
+ function Same(P: Positive) return Positive is (P);
+ package Divisor_Sum is new Generic_Divisors
+ (Result_Type => Natural, None => 0, One => Same, Add => "+");
+
+ type Class_Type is (Deficient, Perfect, Abundant);
+
+ function Class(D_Sum, N: Natural) return Class_Type is
+ (if D_Sum < N then Deficient
+ elsif D_Sum = N then Perfect
+ else Abundant);
+
+ Cls: Class_Type;
+ Results: array (Class_Type) of Natural := (others => 0);
+
+ package NIO is new Ada.Text_IO.Integer_IO(Natural);
+ package CIO is new Ada.Text_IO.Enumeration_IO(Class_Type);
+begin
+ for N in 1 .. 20_000 loop
+ Cls := Class(Divisor_Sum.Process(N), N);
+ Results(Cls) := Results(Cls)+1;
+ end loop;
+ for Class in Results'Range loop
+ CIO.Put(Class, 12);
+ NIO.Put(Results(Class), 8);
+ Ada.Text_IO.New_Line;
+ end loop;
+ Ada.Text_IO.Put_Line("--------------------");
+ Ada.Text_IO.Put("Sum ");
+ NIO.Put(Results(Deficient)+Results(Perfect)+Results(Abundant), 8);
+ Ada.Text_IO.New_Line;
+ Ada.Text_IO.Put_Line("====================");
+end ADB_Classification;
diff --git a/Task/Abundant-deficient-and-perfect-number-classifications/Berkeley-Logo/abundant-deficient-and-perfect-number-classifications.logo b/Task/Abundant-deficient-and-perfect-number-classifications/Berkeley-Logo/abundant-deficient-and-perfect-number-classifications.logo
new file mode 100644
index 0000000000..34985543b5
--- /dev/null
+++ b/Task/Abundant-deficient-and-perfect-number-classifications/Berkeley-Logo/abundant-deficient-and-perfect-number-classifications.logo
@@ -0,0 +1,33 @@
+; Abundant, deficient and perfect number classifications
+
+to print.summary :num.kind :c
+ type sentence "|Number of | :num.kind
+ type "|:|
+ print form :c 6 0
+end
+
+to abundant.etc :max.number
+ make "pds (array :max.number) ; proper divisor sums
+ make "a.count 0
+ make "d.count 0
+ make "p.count 0
+ setitem 1 :pds 0
+ for [i 2 :max.number] [setitem :i :pds 1]
+ for [i 2 :max.number] ~
+ [make "dbl.i :i + :i
+ for [j :dbl.i :max.number :i]
+ [setitem :j :pds (item :j :pds) + :i]]
+ ; Classify the numbers
+ for [i 1 :max.number] ~
+ [make "d.sum (item :i :pds)
+ ifelse :d.sum > :i ~
+ [make "a.count :a.count + 1] ~
+ [ifelse :d.sum < :i ~
+ [make "d.count :d.count + 1] ~
+ [make "p.count :p.count + 1]]]
+ erase [[] [pds] []]
+ print sentence "|Up to| :max.number
+ print.summary "|abundants | :a.count
+ print.summary "|perfects | :p.count
+ print.summary "|deficients| :d.count
+end
diff --git a/Task/Abundant-deficient-and-perfect-number-classifications/Crystal/abundant-deficient-and-perfect-number-classifications.cr b/Task/Abundant-deficient-and-perfect-number-classifications/Crystal/abundant-deficient-and-perfect-number-classifications.cr
new file mode 100644
index 0000000000..2e5aefc80b
--- /dev/null
+++ b/Task/Abundant-deficient-and-perfect-number-classifications/Crystal/abundant-deficient-and-perfect-number-classifications.cr
@@ -0,0 +1,13 @@
+def sum_proper_divisors (n)
+ z = n.class.zero
+ (z+1..n//2).sum(z) {|i| n % i == 0 ? i : 0 }
+end
+
+labels = %w(abundant perfect deficient)
+
+(1..20_000).tally_by {|i| i <=> sum_proper_divisors(i) }
+ .to_a.sort
+ .zip(labels)
+ .each do |(_, count), label|
+ printf "%6d %s\n", count, label
+end
diff --git a/Task/Abundant-deficient-and-perfect-number-classifications/GW-BASIC/abundant-deficient-and-perfect-number-classifications.basic b/Task/Abundant-deficient-and-perfect-number-classifications/GW-BASIC/abundant-deficient-and-perfect-number-classifications.basic
new file mode 100644
index 0000000000..53f97b74c8
--- /dev/null
+++ b/Task/Abundant-deficient-and-perfect-number-classifications/GW-BASIC/abundant-deficient-and-perfect-number-classifications.basic
@@ -0,0 +1,11 @@
+10 DEFINT A-Z: LM=20000
+20 DIM P(LM)
+30 FOR I=1 TO LM: P(I)=-32767: NEXT
+40 FOR I=1 TO LM/2: FOR J=I+I TO LM STEP I: P(J)=P(J)+I: NEXT: NEXT
+50 FOR I=1 TO LM
+60 X=I-32767
+70 IF P(I) i
+ then
+ a_count := a_count + 1
+ else
+ if d_sum < i
+ then
+ d_count := d_count + 1
+ else
+ p_count := p_count + 1
+ fi
+ fi
+ od;
+ writeln("Up to ", max_number: 1);
+ writeln("Number of abundants :", a_count: 6);
+ writeln("Number of perfects :", p_count: 6);
+ writeln("Number of deficients:", d_count: 6);
+end
diff --git a/Task/Abundant-deficient-and-perfect-number-classifications/Minimal-BASIC/abundant-deficient-and-perfect-number-classifications.basic b/Task/Abundant-deficient-and-perfect-number-classifications/Minimal-BASIC/abundant-deficient-and-perfect-number-classifications.basic
new file mode 100644
index 0000000000..e8c2de759d
--- /dev/null
+++ b/Task/Abundant-deficient-and-perfect-number-classifications/Minimal-BASIC/abundant-deficient-and-perfect-number-classifications.basic
@@ -0,0 +1,33 @@
+100 REM Abundant, deficient and perfect number classifications
+110 OPTION BASE 1
+120 REM F(I): sum of proper factors of I
+130 DIM F(20000)
+140 LET M = 20000
+150 LET A = 0
+160 LET D = 0
+170 LET P = 0
+180 LET F(1) = 0
+190 FOR I = 2 TO M
+200 LET F(I) = 1
+210 NEXT I
+220 FOR I = 2 TO M
+230 FOR J = I + I TO M STEP I
+240 LET F(J) = F(J) + I
+250 NEXT J
+260 NEXT I
+270 REM Classify the numbers
+280 FOR I = 1 TO M
+290 LET S = F(I)
+300 IF S <= I THEN 330
+310 LET A = A + 1
+320 GOTO 370
+330 IF S >= I THEN 360
+340 LET D = D + 1
+350 GOTO 370
+360 LET P = P + 1
+370 NEXT I
+380 PRINT "Up to"; M
+390 PRINT "Number of abundants :"; A
+400 PRINT "Number of perfects :"; P
+410 PRINT "Number of deficients:"; D
+420 END
diff --git a/Task/Abundant-deficient-and-perfect-number-classifications/MoonRock/abundant-deficient-and-perfect-number-classifications.moonrock b/Task/Abundant-deficient-and-perfect-number-classifications/MoonRock/abundant-deficient-and-perfect-number-classifications.moonrock
new file mode 100644
index 0000000000..24768330b5
--- /dev/null
+++ b/Task/Abundant-deficient-and-perfect-number-classifications/MoonRock/abundant-deficient-and-perfect-number-classifications.moonrock
@@ -0,0 +1,59 @@
+' Abundant, deficient and perfect number classifications
+
+BEGIN DEF
+SUB PrintStr(S$, Width%)
+%MaxNumber = 1000
+%LastIndex = %MaxNumber - 1
+DIM PDS&[%MaxNumber] ' PDS&[k] proper divisor sums of k + 1 (k + 1 because of indexing from 0)
+'TODO: Check if DIM HUGE is possible. Contrary to the manual, it does not work in MR 0.50
+
+BEGIN CODE
+ACount& = 0
+DCount& = 0
+PCount& = 0
+PDS&[0] = 0
+FOR I% = 1 TO %LastIndex
+ PDS&[I%] = 1
+NEXT
+FOR I% = 2 TO %MaxNumber
+ J% = I% + I%
+ WHILE J% <= %MaxNumber
+ JMin1% = J% - 1
+ PDS&[JMin1%] = PDS&[JMin1%] + I%
+ J% = J% + I%
+ WEND
+NEXT
+' Classify the numbers and count each type
+FOR I& = 1 TO %MaxNumber
+ IMin1& = I& - 1
+ DSum& = PDS&[IMin1&]
+ IF DSum& > I& THEN
+ ACount& = ACount& + 1
+ ELSE
+ IF DSum& < I& THEN
+ DCount& = DCount& + 1
+ ELSE
+ PCount& = PCount& + 1
+ ENDIF
+ ENDIF
+NEXT
+PRINT "Up to " + STR(%MaxNumber) + "\n"
+PRINT "Number of abundants :"
+CALL PrintStr(STR(ACount&), 6)
+PRINT "\n"
+PRINT "Number of perfects :"
+CALL PrintStr(STR(PCount&), 6)
+PRINT "\n"
+PRINT "Number of deficients:"
+CALL PrintStr(STR(DCount&), 6)
+PRINT "\n"
+END
+
+SUB PrintStr(S$, Width%)
+IF LEN(S$) > Width% THEN
+ PRINT S$
+ELSE
+ S$ = SPACE(Width%) + S$
+ PRINT RIGHT(S$, Width%)
+ENDIF
+END SUB
diff --git a/Task/Abundant-deficient-and-perfect-number-classifications/Oberon/abundant-deficient-and-perfect-number-classifications.oberon b/Task/Abundant-deficient-and-perfect-number-classifications/Oberon/abundant-deficient-and-perfect-number-classifications.oberon
new file mode 100644
index 0000000000..20f23f5b48
--- /dev/null
+++ b/Task/Abundant-deficient-and-perfect-number-classifications/Oberon/abundant-deficient-and-perfect-number-classifications.oberon
@@ -0,0 +1,50 @@
+MODULE AbundantDeficientAndPerfect;
+ (* classify the numbers 1 : 20 000 as abudant, deficient or perfect *)
+ IMPORT Out; (* translation of Algol 68 *)
+
+ CONST maxNumber = 20000;
+ VAR abundantCount, deficientCount, perfectCount : INTEGER;
+ pds : ARRAY maxNumber + 1 OF INTEGER;
+
+ (* constructs the table of the proper divisor sums *)
+ PROCEDURE sumDivisors;
+ VAR i, j : INTEGER;
+ BEGIN
+ pds[ 1 ] := 0;
+ FOR i := 2 TO maxNumber DO pds[ i ] := 1 END;
+ FOR i := 2 TO maxNumber DO
+ j := i + i;
+ WHILE j <= maxNumber DO
+ INC( pds[ j ], i );
+ INC( j, i )
+ END
+ END
+ END sumDivisors;
+
+ (* classifies and counts the numbers *)
+ PROCEDURE countAbundantDeficientAndPerfect;
+ VAR n, pdSum : INTEGER;
+ BEGIN
+ abundantCount := 0;
+ deficientCount := 0;
+ perfectCount := 0;
+ FOR n := 1 TO maxNumber DO
+ pdSum := pds[ n ];
+ IF pdSum < n THEN
+ INC( deficientCount )
+ ELSIF pdSum = n THEN
+ INC( perfectCount )
+ ELSE (* pdSum > n *)
+ INC( abundantCount )
+ END
+ END
+ END countAbundantDeficientAndPerfect;
+
+BEGIN
+ sumDivisors;
+ countAbundantDeficientAndPerfect;
+
+ Out.String( "abundant " );Out.Int( abundantCount, 0 );Out.Ln;
+ Out.String( "deficient " );Out.Int( deficientCount, 0 );Out.Ln;
+ Out.String( "perfect " );Out.Int( perfectCount, 0 );Out.Ln
+END AbundantDeficientAndPerfect.
diff --git a/Task/Abundant-deficient-and-perfect-number-classifications/PHP/abundant-deficient-and-perfect-number-classifications.php b/Task/Abundant-deficient-and-perfect-number-classifications/PHP/abundant-deficient-and-perfect-number-classifications.php
new file mode 100644
index 0000000000..dd72f9400c
--- /dev/null
+++ b/Task/Abundant-deficient-and-perfect-number-classifications/PHP/abundant-deficient-and-perfect-number-classifications.php
@@ -0,0 +1,27 @@
+ $i + 1)
+ $a_count++;
+ else if ($d_sum <= $i)
+ $d_count++;
+ else
+ $p_count++;
+}
+echo 'Up to '.MAX_NUMBER.PHP_EOL;
+echo 'Number of abundants :'.str_pad($a_count, 6, " ", STR_PAD_LEFT).PHP_EOL;
+echo 'Number of perfects :'.str_pad($p_count, 6, " ", STR_PAD_LEFT).PHP_EOL;
+echo 'Number of deficients:'.str_pad($d_count, 6, " ", STR_PAD_LEFT).PHP_EOL;
+?>
diff --git a/Task/Abundant-deficient-and-perfect-number-classifications/Pascal-P/abundant-deficient-and-perfect-number-classifications.pas b/Task/Abundant-deficient-and-perfect-number-classifications/Pascal-P/abundant-deficient-and-perfect-number-classifications.pas
new file mode 100644
index 0000000000..fdf657a2cc
--- /dev/null
+++ b/Task/Abundant-deficient-and-perfect-number-classifications/Pascal-P/abundant-deficient-and-perfect-number-classifications.pas
@@ -0,0 +1,34 @@
+program abundantetc(output);
+(* Abundant, deficient and perfect number classifications *)
+
+const
+ maxnumber = 20000;
+var
+ pds: array [1 .. maxnumber] of integer;
+ i, j, acount, dcount, pcount, divsrsum: integer;
+begin
+ acount := 0; dcount := 0; pcount := 0;
+ pds[1] := 0;
+ for i := 2 to maxnumber do pds[i] := 1;
+ for i := 2 to maxnumber do
+ begin
+ j := i + i;
+ while j <= maxnumber do
+ begin
+ pds[j] := pds[j] + i;
+ j := j + i;
+ end;
+ end;
+ (* Classify the numbers and count each type *)
+ for i := 1 to maxnumber do
+ begin
+ divsrsum := pds[i];
+ if divsrsum > i then acount := acount + 1
+ else if divsrsum < i then dcount := dcount + 1
+ else pcount := pcount + 1;
+ end;
+ writeln('Up to', maxnumber: 6);
+ writeln('Number of abundants :', acount: 6);
+ writeln('Number of perfects :', pcount: 6);
+ writeln('Number of deficients:', dcount: 6);
+end.
diff --git a/Task/Abundant-deficient-and-perfect-number-classifications/PowerShell/abundant-deficient-and-perfect-number-classifications-1.ps1 b/Task/Abundant-deficient-and-perfect-number-classifications/PowerShell/abundant-deficient-and-perfect-number-classifications-1.ps1
new file mode 100644
index 0000000000..010bc23ece
--- /dev/null
+++ b/Task/Abundant-deficient-and-perfect-number-classifications/PowerShell/abundant-deficient-and-perfect-number-classifications-1.ps1
@@ -0,0 +1,33 @@
+function Get-ProperDivisorSum ( [int]$N )
+ {
+ If ( $N -lt 2 ) { return 0 }
+
+ $Sum = 1
+ If ( $N -gt 3 )
+ {
+ $SqrtN = [math]::Sqrt( $N )
+ ForEach ( $Divisor in 2..$SqrtN )
+ {
+ If ( $N % $Divisor -eq 0 ) { $Sum += $Divisor + $N / $Divisor }
+ }
+ If ( $N % $SqrtN -eq 0 ) { $Sum -= $SqrtN }
+ }
+ return $Sum
+ }
+
+
+$Deficient = $Perfect = $Abundant = 0
+
+ForEach ( $N in 1..20000 )
+ {
+ Switch ( [math]::Sign( ( Get-ProperDivisorSum $N ) - $N ) )
+ {
+ -1 { $Deficient++ }
+ 0 { $Perfect++ }
+ 1 { $Abundant++ }
+ }
+ }
+
+"Deficient: $Deficient"
+"Perfect : $Perfect"
+"Abundant : $Abundant"
diff --git a/Task/Abundant-deficient-and-perfect-number-classifications/PowerShell/abundant-deficient-and-perfect-number-classifications-2.ps1 b/Task/Abundant-deficient-and-perfect-number-classifications/PowerShell/abundant-deficient-and-perfect-number-classifications-2.ps1
new file mode 100644
index 0000000000..74593a216c
--- /dev/null
+++ b/Task/Abundant-deficient-and-perfect-number-classifications/PowerShell/abundant-deficient-and-perfect-number-classifications-2.ps1
@@ -0,0 +1,56 @@
+function Get-NumberClassification
+{
+ [CmdletBinding()]
+ [OutputType([PSCustomObject])]
+ Param
+ (
+ [Parameter(Mandatory=$true,
+ ValueFromPipeline=$true,
+ ValueFromPipelineByPropertyName=$true,
+ Position=0)]
+ [int]
+ $Number
+ )
+
+ Begin
+ {
+ function Get-ProperDivisorSum ([int]$Number)
+ {
+ if ($Number -lt 2) {return 0}
+
+ $sum = 1
+
+ if ($Number -gt 3)
+ {
+ $sqrtNumber = [Math]::Sqrt($Number)
+
+ foreach ($divisor in 2..$sqrtNumber)
+ {
+ if ($Number % $divisor -eq 0) {$sum += $divisor + $Number / $divisor}
+ }
+
+ if ($Number % $sqrtNumber -eq 0) {$sum -= $sqrtNumber}
+ }
+
+ $sum
+ }
+
+ [System.Collections.ArrayList]$numbers = @()
+ }
+ Process
+ {
+ switch ([Math]::Sign((Get-ProperDivisorSum $Number) - $Number))
+ {
+ -1 { [void]$numbers.Add([PSCustomObject]@{Class="Deficient"; Number=$Number}) }
+ 0 { [void]$numbers.Add([PSCustomObject]@{Class="Perfect" ; Number=$Number}) }
+ 1 { [void]$numbers.Add([PSCustomObject]@{Class="Abundant" ; Number=$Number}) }
+ }
+ }
+ End
+ {
+ $numbers | Group-Object -Property Class |
+ Select-Object -Property Count,
+ @{Name='Class' ; Expression={$_.Name}},
+ @{Name='Number'; Expression={$_.Group.Number}}
+ }
+}
diff --git a/Task/Abundant-deficient-and-perfect-number-classifications/PowerShell/abundant-deficient-and-perfect-number-classifications-3.ps1 b/Task/Abundant-deficient-and-perfect-number-classifications/PowerShell/abundant-deficient-and-perfect-number-classifications-3.ps1
new file mode 100644
index 0000000000..fd9ab5621c
--- /dev/null
+++ b/Task/Abundant-deficient-and-perfect-number-classifications/PowerShell/abundant-deficient-and-perfect-number-classifications-3.ps1
@@ -0,0 +1 @@
+1..20000 | Get-NumberClassification
diff --git a/Task/Abundant-deficient-and-perfect-number-classifications/Uiua/abundant-deficient-and-perfect-number-classifications.uiua b/Task/Abundant-deficient-and-perfect-number-classifications/Uiua/abundant-deficient-and-perfect-number-classifications.uiua
new file mode 100644
index 0000000000..cba50fafa9
--- /dev/null
+++ b/Task/Abundant-deficient-and-perfect-number-classifications/Uiua/abundant-deficient-and-perfect-number-classifications.uiua
@@ -0,0 +1,11 @@
+# Given a positive integer, find the divisors
+Divs ← (
+ ⇡₁⌊√⊸∘ # n -- n trial_divisors
+ ⊙(⇌÷) ⟜∘ +1⊚=0⊸◿ # partition into small, large divisors
+ ⊂↘¯=◡(∩⊢⊣) # join the arrays, but compensate for squares
+)
+
+ProperSum ← /+↘¯1 Divs
+Class ← ± -⟜ProperSum
+
+&p $"_ deficient, _ perfect, _ abundant." °⊟₃ ⊕⧻ ⊸⊛ ≡Class ⇡₁2e4
diff --git a/Task/Abundant-deficient-and-perfect-number-classifications/VBScript/abundant-deficient-and-perfect-number-classifications.vbs b/Task/Abundant-deficient-and-perfect-number-classifications/VBScript/abundant-deficient-and-perfect-number-classifications.vbs
new file mode 100644
index 0000000000..17ddc48cbf
--- /dev/null
+++ b/Task/Abundant-deficient-and-perfect-number-classifications/VBScript/abundant-deficient-and-perfect-number-classifications.vbs
@@ -0,0 +1,23 @@
+Deficient = 0
+Perfect = 0
+Abundant = 0
+For i = 1 To 20000
+ sum = 0
+ For n = 1 To 20000
+ If n < i Then
+ If i Mod n = 0 Then
+ sum = sum + n
+ End If
+ End If
+ Next
+ If sum < i Then
+ Deficient = Deficient + 1
+ ElseIf sum = i Then
+ Perfect = Perfect + 1
+ ElseIf sum > i Then
+ Abundant = Abundant + 1
+ End If
+Next
+WScript.Echo "Deficient = " & Deficient & vbCrLf &_
+ "Perfect = " & Perfect & vbCrLf &_
+ "Abundant = " & Abundant
diff --git a/Task/Abundant-odd-numbers/ANSI-BASIC/abundant-odd-numbers.basic b/Task/Abundant-odd-numbers/ANSI-BASIC/abundant-odd-numbers.basic
new file mode 100644
index 0000000000..9f7c01e624
--- /dev/null
+++ b/Task/Abundant-odd-numbers/ANSI-BASIC/abundant-odd-numbers.basic
@@ -0,0 +1,49 @@
+100 REM Abundant odd numbers
+110 DECLARE EXTERNAL FUNCTION DivisorSum
+120 REM first 25 odd abundant numbers
+130 LET OddNumber = 1
+140 LET ACount = 0
+150 LET DSum = 0
+160 PRINT "The first 25 abundant odd numbers:"
+170 DO WHILE ACount < 25
+180 LET DSum = DivisorSum(OddNumber)
+190 IF DSum > OddNumber THEN
+200 LET ACount = Acount + 1
+210 PRINT USING "######": OddNumber;
+220 PRINT " proper divisor sum: ";
+230 PRINT USING "######": DSum
+240 END IF
+250 LET OddNumber = OddNumber + 2
+260 LOOP
+270 REM 1000th odd abundant number
+280 DO WHILE ACount < 1000
+290 LET DSum = DivisorSum(OddNumber)
+300 IF DSum > OddNumber THEN LET ACount = Acount + 1
+310 LET OddNumber = OddNumber + 2
+320 LOOP
+330 PRINT "1000th abundant odd number:"
+340 PRINT " "; OddNumber - 2; "proper divisor sum:"; DSum
+350 REM first odd abundant number > 1000000000
+360 LET OddNumber = 1000000001
+370 LET Found = 0
+380 DO WHILE Found = 0
+390 LET DSum = DivisorSum(OddNumber)
+400 IF DSum > OddNumber THEN
+410 LET Found = 1
+420 PRINT "First abundant odd number > 1 000 000 000:"
+430 PRINT " "; OddNumber; "proper divisor sum:"; DSum
+440 END IF
+450 LET OddNumber = OddNumber + 2
+460 LOOP
+470 END
+480 External Function DivisorSum(N)
+490 LET Sum = 1
+500 FOR D = 2 TO INT(SQR(N))
+510 IF MOD(N, D) = 0 THEN
+520 LET Sum = Sum + D
+530 LET OtherD = INT(N / D)
+540 IF OtherD <> D THEN LET Sum = Sum + OtherD
+550 END IF
+560 NEXT D
+570 LET DivisorSum = Sum
+580 END FUNCTION
diff --git a/Task/Abundant-odd-numbers/Ada/abundant-odd-numbers.adb b/Task/Abundant-odd-numbers/Ada/abundant-odd-numbers.adb
new file mode 100644
index 0000000000..a393c7c42a
--- /dev/null
+++ b/Task/Abundant-odd-numbers/Ada/abundant-odd-numbers.adb
@@ -0,0 +1,57 @@
+with Ada.Text_IO, Generic_Divisors;
+
+procedure Odd_Abundant is
+ function Same(P: Positive) return Positive is (P);
+
+ package Divisor_Sum is new Generic_Divisors
+ (Result_Type => Natural, None => 0, One => Same, Add => "+");
+
+ function Abundant(N: Positive) return Boolean is
+ (Divisor_Sum.Process(N) > N);
+
+ package NIO is new Ada.Text_IO.Integer_IO(Natural);
+
+ Current: Positive := 1;
+
+ procedure Print_Abundant_Line
+ (Idx: Positive; N: Positive; With_Idx: Boolean:= True) is
+ begin
+ if With_Idx then
+ NIO.Put(Idx, 6); Ada.Text_IO.Put(" |");
+ else
+ Ada.Text_IO.Put(" *** |");
+ end if;
+ NIO.Put(N, 12); Ada.Text_IO.Put(" | ");
+ NIO.Put(Divisor_Sum.Process(N), 12); Ada.Text_IO.New_Line;
+ end Print_Abundant_Line;
+
+begin
+ -- the first 25 abundant odd numbers
+ Ada.Text_IO.Put_Line(" index | number | proper divisor sum ");
+ Ada.Text_IO.Put_Line("-------+-------------+--------------------");
+ for I in 1 .. 25 loop
+ while not Abundant(Current) loop
+ Current := Current + 2;
+ end loop;
+ Print_Abundant_Line(I, Current);
+ Current := Current + 2;
+ end loop;
+
+ -- the one thousandth abundant odd number
+ Ada.Text_IO.Put_Line("-------+-------------+--------------------");
+ for I in 26 .. 1_000 loop
+ Current := Current + 2;
+ while not Abundant(Current) loop
+ Current := Current + 2;
+ end loop;
+ end loop;
+ Print_Abundant_Line(1000, Current);
+
+ -- the first abundant odd number greater than 10**9
+ Ada.Text_IO.Put_Line("-------+-------------+--------------------");
+ Current := 10**9+1;
+ while not Abundant(Current) loop
+ Current := Current + 2;
+ end loop;
+ Print_Abundant_Line(1, Current, False);
+end Odd_Abundant;
diff --git a/Task/Abundant-odd-numbers/BQN/abundant-odd-numbers.bqn b/Task/Abundant-odd-numbers/BQN/abundant-odd-numbers.bqn
new file mode 100644
index 0000000000..703a5b4dd2
--- /dev/null
+++ b/Task/Abundant-odd-numbers/BQN/abundant-odd-numbers.bqn
@@ -0,0 +1,20 @@
+Divisors ← {
+ n ← 𝕩 ⋄ r ← ⌊√n
+ lower ← 1 + /0 = (1↓↕r+1)|¨n
+ upper ← {n ÷ 𝕩}¨lower
+ lower ∾ (n = r⋆2)↓⌽upper
+}
+
+Proper ← {(-𝕩) +´ Divisors 𝕩}
+Abundant ← {𝕩 < Proper 𝕩}
+
+kap ← 250_000 # number of candidates to test
+a ← 1+2×/Abundant¨1+2×↕kap
+
+•Out "The first 25 abundant odd numbers:"
+{•Out (•Fmt 𝕩)∾"; proper sum: "∾•Fmt Proper 𝕩}¨25↑a
+
+•Out "The 1000th: "∾(•Fmt 999 ⊑ a)∾"; proper sum: "∾•Fmt Proper 999 ⊑ a
+
+big ← {𝕩+2} •_while_(¬Abundant) 1000000001
+•Out "The first > 1e9: " ∾(•Fmt big)∾"; proper sum: "∾•Fmt Proper big
diff --git a/Task/Abundant-odd-numbers/COBOL/abundant-odd-numbers.cob b/Task/Abundant-odd-numbers/COBOL/abundant-odd-numbers.cob
new file mode 100644
index 0000000000..b71d41d8a1
--- /dev/null
+++ b/Task/Abundant-odd-numbers/COBOL/abundant-odd-numbers.cob
@@ -0,0 +1,100 @@
+IDENTIFICATION DIVISION.
+ PROGRAM-ID. ABUNDANT-ODD-NUMBERS.
+
+ ENVIRONMENT DIVISION.
+
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 WS-VARIABLES.
+ 05 WS-ODD-NUM PIC 9(10).
+ 05 WS-TO-DIVIDE PIC 9(10).
+ 05 WS-REMAINDER PIC 9(10).
+ 05 WS-SUM PIC 9(10).
+ 05 WS-RESULT-COUNT PIC 9(5) VALUE 0.
+ 05 WS-LIST-INDEX PIC 9(5) VALUE 0.
+ 05 WS-START PIC 9(10).
+ 05 WS-FINISH PIC 9(10).
+ 05 WS-LIST-SIZE PIC 9(5).
+ 05 WS-PRINT-ONE PIC X VALUE 'N'.
+
+ 01 WS-DIVISOR-LIST.
+ 05 WS-DIVISOR OCCURS 1000 TIMES PIC 9(10).
+
+ 01 WS-DISPLAY-FIELDS.
+ 05 WS-DISPLAY-NUM PIC Z(5)9.
+ 05 WS-DISPLAY-SUM PIC Z(5)9.
+
+ PROCEDURE DIVISION.
+ MAIN-PROCEDURE.
+ DISPLAY "First 24: ".
+ MOVE 1 TO WS-START.
+ MOVE 100000 TO WS-FINISH.
+ MOVE 25 TO WS-LIST-SIZE.
+ MOVE 'N' TO WS-PRINT-ONE.
+ PERFORM ABUNDANT-ODD.
+
+ DISPLAY " ".
+ DISPLAY " ".
+ DISPLAY "Thousandth: ".
+ MOVE 0 TO WS-RESULT-COUNT.
+ MOVE 1 TO WS-START.
+ MOVE 2500000 TO WS-FINISH.
+ MOVE 1000 TO WS-LIST-SIZE.
+ MOVE 'Y' TO WS-PRINT-ONE.
+ PERFORM ABUNDANT-ODD.
+
+ DISPLAY " ".
+ DISPLAY " ".
+ DISPLAY "First over 1bn:".
+ MOVE 0 TO WS-RESULT-COUNT.
+ MOVE 1000000001 TO WS-START.
+ MOVE 2147483647 TO WS-FINISH.
+ MOVE 1 TO WS-LIST-SIZE.
+ MOVE 'N' TO WS-PRINT-ONE.
+ PERFORM ABUNDANT-ODD.
+
+ STOP RUN.
+
+ ABUNDANT-ODD.
+ MOVE WS-START TO WS-ODD-NUM.
+ IF FUNCTION MOD(WS-ODD-NUM, 2) = 0
+ ADD 1 TO WS-ODD-NUM
+ END-IF.
+
+ PERFORM UNTIL WS-ODD-NUM >= WS-FINISH
+ OR WS-RESULT-COUNT >= WS-LIST-SIZE
+ MOVE 0 TO WS-LIST-INDEX
+ MOVE 0 TO WS-SUM
+
+ PERFORM VARYING WS-TO-DIVIDE FROM 1 BY 2
+ UNTIL WS-TO-DIVIDE >= WS-ODD-NUM
+ DIVIDE WS-ODD-NUM BY WS-TO-DIVIDE
+ GIVING WS-REMAINDER
+ REMAINDER WS-REMAINDER
+ END-DIVIDE
+
+ IF WS-REMAINDER = 0
+ ADD 1 TO WS-LIST-INDEX
+ MOVE WS-TO-DIVIDE TO WS-DIVISOR(WS-LIST-INDEX)
+ ADD WS-TO-DIVIDE TO WS-SUM
+ END-IF
+ END-PERFORM
+
+ IF WS-SUM > WS-ODD-NUM
+ ADD 1 TO WS-RESULT-COUNT
+ IF WS-PRINT-ONE = 'N'
+ MOVE WS-ODD-NUM TO WS-DISPLAY-NUM
+ MOVE WS-SUM TO WS-DISPLAY-SUM
+ DISPLAY WS-DISPLAY-NUM " <= " WS-DISPLAY-SUM
+ END-IF
+ END-IF
+
+ IF WS-PRINT-ONE = 'Y'
+ AND WS-RESULT-COUNT >= WS-LIST-SIZE
+ MOVE WS-ODD-NUM TO WS-DISPLAY-NUM
+ MOVE WS-SUM TO WS-DISPLAY-SUM
+ DISPLAY WS-DISPLAY-NUM " <= " WS-DISPLAY-SUM
+ END-IF
+
+ ADD 2 TO WS-ODD-NUM
+ END-PERFORM.
diff --git a/Task/Abundant-odd-numbers/Crystal/abundant-odd-numbers.cr b/Task/Abundant-odd-numbers/Crystal/abundant-odd-numbers.cr
new file mode 100644
index 0000000000..d5beac4356
--- /dev/null
+++ b/Task/Abundant-odd-numbers/Crystal/abundant-odd-numbers.cr
@@ -0,0 +1,30 @@
+def sum_proper_odd_divisors (n)
+ √n = Math.isqrt(n)
+ z = n.class.zero
+ sum = z+1
+ (z+3 .. √n).step(2) do |i|
+ if n % i == 0
+ sum += i + (i == (j = n // i) ? 0 : j)
+ end
+ end
+ sum
+end
+
+def abunseq (start=1)
+ start += 1 unless start.odd?
+ (start..).step(2).each.select {|n| n < sum_proper_odd_divisors(n) }
+end
+
+iter = abunseq
+puts "First 25:"
+iter.first(25).each do |aon|
+ printf "%6d (%d)\n", aon, sum_proper_odd_divisors(aon)
+end
+
+n1k = iter.skip(999-25).next
+raise "?" if n1k.is_a?(Iterator::Stop)
+print "\nThe 1000th: ", n1k, " (", sum_proper_odd_divisors(n1k), ")"
+
+n1b = abunseq(1_000_000_000).next
+raise "?" if n1b.is_a?(Iterator::Stop)
+print "\nThe first > 1B: ", n1b, " (", sum_proper_odd_divisors(n1b), ")\n"
diff --git a/Task/Abundant-odd-numbers/Pascal/abundant-odd-numbers.pas b/Task/Abundant-odd-numbers/Free-Pascal-Lazarus/abundant-odd-numbers.pas
similarity index 100%
rename from Task/Abundant-odd-numbers/Pascal/abundant-odd-numbers.pas
rename to Task/Abundant-odd-numbers/Free-Pascal-Lazarus/abundant-odd-numbers.pas
diff --git a/Task/Abundant-odd-numbers/K/abundant-odd-numbers.k b/Task/Abundant-odd-numbers/K/abundant-odd-numbers.k
new file mode 100644
index 0000000000..26ff10cb5b
--- /dev/null
+++ b/Task/Abundant-odd-numbers/K/abundant-odd-numbers.k
@@ -0,0 +1,20 @@
+divs: {
+ r: _%x;
+ lower: 1 + &0 = (1 + !r)!' x;
+ upper: ({(-y)!x}[x;])' lower;
+ lower, (x = r*r)_|upper}
+
+proper: {(-x) +/ divs x}
+abundant: {x < proper x}
+
+kap: 250000 /number of candidates to test; tweak until result is above 1k
+
+n: 1+2*!kap
+a: n[&abundant' n]
+
+`0: "The first 25 abundant odd numbers:"
+nulls: {`0: ($x), "; proper sum: ", $proper x}' 25#a
+`0: "The 1000th: ", ($a[999]), "; proper sum: ", $proper a[999]
+
+big: {~abundant x} {x+2}/ 1000000001
+`0: "The first > 1e9: ", ($big), "; proper sum: ", $proper big
diff --git a/Task/Abundant-odd-numbers/Loglan82/abundant-odd-numbers.loglan82 b/Task/Abundant-odd-numbers/Loglan82/abundant-odd-numbers.loglan82
new file mode 100644
index 0000000000..21154c7e94
--- /dev/null
+++ b/Task/Abundant-odd-numbers/Loglan82/abundant-odd-numbers.loglan82
@@ -0,0 +1,65 @@
+program AbundantOdd;
+(* Abundant odd numbers *)
+
+var
+ odd_number, a_count, d_sum: integer,
+ found: boolean;
+
+ (* Returns the sum of the proper divisors of n *)
+ unit divisor_sum: function (n: integer): integer;
+ var
+ sum, d, sqrt_n, other_d: integer;
+ begin
+ sum := 1;
+ sqrt_n := entier(sqrt(n));
+ for d := 2 to sqrt_n
+ do
+ if n mod d = 0
+ then
+ sum := sum + d;
+ other_d := n div d;
+ if other_d =/= d then sum := sum + other_d fi;
+ fi;
+ od;
+ result := sum;
+ end divisor_sum;
+
+begin
+ (* first 25 odd abundant numbers *)
+ odd_number := 1;
+ a_count := 0;
+ d_sum := 0;
+ writeln("The first 25 abundant odd numbers:");
+ while a_count < 25
+ do
+ d_sum := divisor_sum(odd_number);
+ if d_sum > odd_number
+ then
+ a_count := a_count + 1;
+ writeln(odd_number: 6, " proper divisor sum: ", d_sum: 6);
+ fi;
+ odd_number := odd_number + 2;
+ od;
+ (* 1000th odd abundant number *)
+ while a_count < 1000
+ do
+ d_sum := divisor_sum(odd_number);
+ if d_sum > odd_number then a_count := a_count + 1 fi;
+ odd_number := odd_number + 2
+ od;
+ writeln("1000th abundant odd number:");
+ writeln(" ", odd_number - 2: 1, " proper divisor sum: ", d_sum: 1);
+ (* First odd abundant number > 1000000000 *)
+ odd_number := 1000000001;
+ found := false;
+ while not found do
+ d_sum := divisor_sum(odd_number);
+ if d_sum > odd_number
+ then
+ found := true;
+ writeln("First abundant odd number > 1 000 000 000:");
+ writeln(" ", odd_number: 1, " proper divisor sum: ", d_sum: 1);
+ fi;
+ odd_number := odd_number + 2
+ od;
+end AbundantOdd.
diff --git a/Task/Abundant-odd-numbers/Modula-2/abundant-odd-numbers.mod2 b/Task/Abundant-odd-numbers/Modula-2/abundant-odd-numbers.mod2
new file mode 100644
index 0000000000..2a6df42459
--- /dev/null
+++ b/Task/Abundant-odd-numbers/Modula-2/abundant-odd-numbers.mod2
@@ -0,0 +1,80 @@
+MODULE AbundantOdd;
+(* Abundant odd numbers *)
+FROM SWholeIO IMPORT
+ WriteInt;
+FROM STextIO IMPORT
+ WriteLn, WriteString;
+FROM RealMath IMPORT
+ sqrt;
+
+VAR
+ OddNumber, ACount, DSum: CARDINAL;
+ Found: BOOLEAN;
+
+PROCEDURE DivisorSum(N: CARDINAL): CARDINAL;
+VAR
+ D, OtherD, Sum: CARDINAL;
+BEGIN
+ Sum := 1;
+ FOR D := 2 TO TRUNC(sqrt(FLOAT(N))) DO
+ IF N MOD D = 0 THEN
+ Sum := Sum + D;
+ OtherD := N DIV D;
+ IF OtherD <> D THEN
+ Sum := Sum + OtherD
+ END;
+ END;
+ END;
+ RETURN Sum
+END DivisorSum;
+
+BEGIN
+ (* First 25 odd abundant numbers *)
+ OddNumber := 1;
+ ACount := 0;
+ DSum := 0;
+ WriteString("The first 25 abundant odd numbers:");
+ WriteLn;
+ WHILE ACount < 25 DO
+ DSum := DivisorSum(OddNumber);
+ IF DSum > OddNumber THEN
+ ACount := ACount + 1;
+ WriteInt(OddNumber, 6);
+ WriteString(" proper divisor sum: ");
+ WriteInt(DSum, 6);
+ WriteLn
+ END;
+ OddNumber := OddNumber + 2
+ END;
+ (* 1000th odd abundant number *)
+ WHILE ACount < 1000 DO
+ DSum := DivisorSum(OddNumber);
+ IF DSum > OddNumber THEN
+ ACount := ACount + 1
+ END;
+ OddNumber := OddNumber + 2
+ END;
+ WriteString("1000th abundant odd number:");
+ WriteLn;
+ WriteString(" ");
+ WriteInt(OddNumber - 2, 1);
+ WriteString(" proper divisor sum: ");
+ WriteInt(DSum, 1);
+ WriteLn;
+ (* First odd abundant number > 1000000000 *)
+ OddNumber := 1000000001;
+ Found := FALSE;
+ WHILE NOT Found DO
+ DSum := DivisorSum(OddNumber);
+ IF DSum > OddNumber THEN
+ Found := TRUE;
+ WriteString("First abundant odd number > 1 000 000 000:");
+ WriteLn;
+ WriteString(" ");
+ WriteInt(OddNumber, 1);
+ WriteString(" proper divisor sum: ");
+ WriteInt(DSum, 1);
+ END;
+ OddNumber := OddNumber + 2
+ END;
+END AbundantOdd.
diff --git a/Task/Abundant-odd-numbers/Oberon-07/abundant-odd-numbers.oberon b/Task/Abundant-odd-numbers/Oberon-07/abundant-odd-numbers.oberon
new file mode 100644
index 0000000000..d90e21a5a0
--- /dev/null
+++ b/Task/Abundant-odd-numbers/Oberon-07/abundant-odd-numbers.oberon
@@ -0,0 +1,69 @@
+MODULE AbundantOddNumbers;
+ (* find some abundant odd numbers - numbers where the proper divisor sum *)
+ (* is bigger than the number itself *)
+
+ IMPORT Out, Math;
+
+ (* returns the sum of the proper divisors of n *)
+ PROCEDURE divisorSum( n : INTEGER ) : INTEGER;
+ VAR sum, d, otherD : INTEGER;
+
+ BEGIN
+ sum := 1;
+ FOR d := 2 TO FLOOR( Math.sqrt( FLT( n ) ) ) DO
+ IF n MOD d = 0 THEN
+ INC( sum, d );
+ otherD := n DIV d;
+ IF otherD # d THEN INC( sum, otherD ) END
+ END
+ END;
+ RETURN sum
+ END divisorSum;
+
+ PROCEDURE doTask; (* find the numbers required by the task *)
+ VAR oddNumber, aCount, dSum : INTEGER;
+ found : BOOLEAN;
+ BEGIN
+
+ (* first 25 odd abundant numbers *)
+ oddNumber := 1;
+ aCount := 0;
+ dSum := 0;
+ Out.String( "The first 25 abundant odd numbers:" );Out.Ln;
+ WHILE aCount < 25 DO
+ dSum := divisorSum( oddNumber );
+ IF dSum > oddNumber THEN
+ INC( aCount );
+ Out.Int( oddNumber, 6 );Out.String( " proper divisor sum: " );Out.Int( dSum, 0 );Out.Ln
+ END;
+ INC( oddNumber, 2 )
+ END;
+
+ (* 1000th odd abundant number *)
+ WHILE aCount < 1000 DO
+ dSum := divisorSum( oddNumber );
+ IF dSum > oddNumber THEN
+ INC( aCount )
+ END;
+ INC( oddNumber, 2 )
+ END;
+ Out.String( "1000th abundant odd number:" );Out.Ln;Out.String( " " );
+ Out.Int( oddNumber - 2, 0 );Out.String( " proper divisor sum: " );Out.Int( dSum, 0 );Out.Ln;
+
+ (* first odd abundant number > one billion *)
+ oddNumber := 1000000001;
+ found := FALSE;
+ WHILE ~ found DO
+ dSum := divisorSum( oddNumber );
+ IF dSum > oddNumber THEN
+ found := TRUE;
+ Out.String( "First abundant odd number > 1 000 000 000:" );Out.Ln;Out.String( " " );
+ Out.Int( oddNumber, 0 );Out.String( " proper divisor sum: " );Out.Int( dSum, 0 );Out.Ln
+ END;
+ INC( oddNumber, 2 )
+ END
+ END doTask;
+
+BEGIN
+ doTask
+END AbundantOddNumbers.
diff --git a/Task/Abundant-odd-numbers/PHP/abundant-odd-numbers.php b/Task/Abundant-odd-numbers/PHP/abundant-odd-numbers.php
new file mode 100644
index 0000000000..a5ee26efd5
--- /dev/null
+++ b/Task/Abundant-odd-numbers/PHP/abundant-odd-numbers.php
@@ -0,0 +1,53 @@
+ $odd_number) {
+ $a_count++;
+ echo str_pad($odd_number, 6, " ", STR_PAD_LEFT).
+ ' proper divisor sum: '.
+ str_pad($d_sum, 6, " ", STR_PAD_LEFT).PHP_EOL;
+ }
+ $odd_number += 2;
+}
+// 1000th odd abundant number
+while ($a_count < 1000) {
+ $d_sum = divisor_sum($odd_number);
+ if ($d_sum > $odd_number)
+ $a_count++;
+ $odd_number += 2;
+}
+echo '1000th abundant odd number:'.PHP_EOL;
+echo ' '.($odd_number - 2).' proper divisor sum: '.$d_sum.PHP_EOL;
+// first odd abundant number > 1000000000
+$odd_number = 1000000001;
+$found = false;
+while (!$found) {
+ $d_sum = divisor_sum($odd_number);
+ if ($d_sum > $odd_number) {
+ $found = true;
+ echo 'First abundant odd number > 1 000 000 000:'.PHP_EOL;
+ echo ' '.$odd_number.' proper divisor sum: '.$d_sum.PHP_EOL;
+ }
+ $odd_number += 2;
+}
+?>
diff --git a/Task/Abundant-odd-numbers/PL-I/abundant-odd-numbers.pli b/Task/Abundant-odd-numbers/PL-I/abundant-odd-numbers.pli
new file mode 100644
index 0000000000..cf63f05fee
--- /dev/null
+++ b/Task/Abundant-odd-numbers/PL-I/abundant-odd-numbers.pli
@@ -0,0 +1,39 @@
+/* Abundant odd numbers (1st part) */
+
+abundant_odd:
+ procedure options(main);
+ /* first 25 odd abundant numbers */
+ declare
+ (odd_number, a_count, d_sum) fixed binary(15);
+ odd_number = 1;
+ a_count = 0;
+ d_sum = 0;
+ put list('The first 25 abundant odd numbers:');
+ do while (a_count < 25);
+ d_sum = divisor_sum(odd_number);
+ if d_sum > odd_number then do;
+ a_count = a_count + 1;
+ put skip edit(odd_number, ' proper divisor sum: ', d_sum)
+ (f(6), a, f(6));
+ end;
+ odd_number = odd_number + 2;
+ end;
+
+ /* returns the sum of the proper divisors of n */
+ divisor_sum:
+ procedure (n) returns (fixed binary(15));
+ declare
+ (n, sum, d, sqrt_n, other_d) fixed binary(15);
+ sum = 1;
+ sqrt_n = sqrt(n);
+ do d = 2 to sqrt_n;
+ if mod(n, d) = 0 then do;
+ sum = sum + d;
+ other_d = n / d;
+ if other_d ~= d then
+ sum = sum + other_d;
+ end;
+ end;
+ return (sum);
+ end divisor_sum;
+end abundant_odd;
diff --git a/Task/Abundant-odd-numbers/Pascal-P/abundant-odd-numbers.pas b/Task/Abundant-odd-numbers/Pascal-P/abundant-odd-numbers.pas
new file mode 100644
index 0000000000..1968c93432
--- /dev/null
+++ b/Task/Abundant-odd-numbers/Pascal-P/abundant-odd-numbers.pas
@@ -0,0 +1,68 @@
+program abundodd(output);
+
+ (* Abundant odd numbers *)
+
+var
+ oddnumber, acount, dsum: integer;
+ found: boolean;
+
+ (* returns the sum of the proper divisors of n *)
+ function divisorsum(n: integer): integer;
+ var
+ sum, d, otherd: integer;
+ begin
+ sum := 1;
+ for d := 2 to trunc(sqrt(n)) do
+ if n mod d = 0 then
+ begin
+ sum := sum + d;
+ otherd := n div d;
+ if otherd <> d then
+ sum := sum + otherd;
+ end;
+ divisorsum := sum;
+ end;
+
+begin
+ (* first 25 odd abundant numbers *)
+ oddnumber := 1;
+ acount := 0;
+ dsum := 0;
+ writeln('The first 25 abundant odd numbers:');
+ while acount < 25 do
+ begin
+ dsum := divisorsum(oddnumber);
+ if dsum > oddnumber then
+ begin
+ acount := acount + 1;
+ writeln(oddnumber: 6, ' proper divisor sum: ', dsum: 6);
+ end;
+ oddnumber := oddnumber + 2;
+ end;
+
+ (* 1000th odd abundant number - requires 32-bit integer *)
+ while acount < 1000 do
+ begin
+ dsum := divisorsum(oddnumber);
+ if dsum > oddnumber then
+ acount := acount + 1;
+ oddnumber := oddnumber + 2;
+ end;
+ writeln('1000th abundant odd number:');
+ writeln(' ', oddnumber - 2: 1, ' proper divisor sum: ', dsum: 1);
+ (* first odd abundant number > 1000000000 - requires 32-bit integer *)
+ oddnumber := 1000000001;
+ found := false;
+ while not found do
+ begin
+ dsum := divisorsum(oddnumber);
+ if dsum > oddnumber then
+ begin
+ found := true;
+ writeln('First abundant odd number > 1 000 000 000:');
+ writeln(' ', oddnumber: 1, ' proper divisor sum: ', dsum: 1);
+ end;
+ oddnumber := oddnumber + 2;
+ end;
+ (* readln; *)
+end.
diff --git a/Task/Abundant-odd-numbers/PowerShell/abundant-odd-numbers.ps1 b/Task/Abundant-odd-numbers/PowerShell/abundant-odd-numbers.ps1
new file mode 100644
index 0000000000..b521d170e5
--- /dev/null
+++ b/Task/Abundant-odd-numbers/PowerShell/abundant-odd-numbers.ps1
@@ -0,0 +1,57 @@
+# Abundant odd numbers
+
+# Returns the sum of the proper divisors of $N
+function Divisor-Sum([uint32]$N) {
+ [uint32]$sum = 1
+ [uint32]$intSqrtN = [uint32]([Math]::Sqrt($N))
+ for ($d = 2; $d -le $intSqrtN; $d++) {
+ # The for loop is used because foreach goes downwards if $intSqrtN < 2
+ if ($N % $d -eq 0) {
+ $sum += $d
+ [uint32]$otherD = $N / $d
+ if ($otherD -ne $d) {
+ $sum += $otherD
+ }
+ }
+ }
+ return $sum
+}
+
+# first 25 odd abundant numbers
+[uint32]$oddNumber = 1
+[uint32]$aCount = 0
+[uint32]$dSum = 0
+Write-Output "The first 25 abundant odd numbers:"
+while ($aCount -lt 25) {
+ $dSum = Divisor-Sum $oddNumber
+ if ($dSum -gt $oddNumber) {
+ $aCount++
+ [string]$out = "{0, 6} proper divisor sum: {1, 6}" -f $oddNumber, $dSum
+ Write-Output $out
+ }
+ $oddNumber += 2
+}
+
+# 1000th odd abundant number
+while ($aCount -lt 1000) {
+ $dSum = Divisor-Sum $oddNumber
+ if ($dSum -gt $oddNumber) {
+ $aCount++
+ }
+ $oddNumber += 2
+}
+Write-Output "1000th abundant odd number:"
+Write-Output " $($oddNumber - 2) proper divisor sum: $dSum"
+
+# first odd abundant number > 1000000000
+$oddNumber = 1000000001
+[bool]$found = $false
+while (-not $found) {
+ $dSum = Divisor-Sum $oddNumber
+ if ($dSum -gt $oddNumber) {
+ $found = $true
+ Write-Output "First abundant odd number > 1 000 000 000:"
+ Write-Output " $oddNumber proper divisor sum: $dSum"
+ }
+ $oddNumber += 2
+}
diff --git a/Task/Abundant-odd-numbers/QuickBASIC/abundant-odd-numbers.basic b/Task/Abundant-odd-numbers/QuickBASIC/abundant-odd-numbers.basic
new file mode 100644
index 0000000000..7f0b6b4b66
--- /dev/null
+++ b/Task/Abundant-odd-numbers/QuickBASIC/abundant-odd-numbers.basic
@@ -0,0 +1,54 @@
+' Abundant odd numbers
+DECLARE FUNCTION DivisorSum& (N AS LONG)
+' First 25 odd abundant numbers
+CONST TRUE% = -1, FALSE% = 0
+DIM OddNumber AS LONG, Acount AS LONG, DSum AS LONG
+DIM Found AS INTEGER
+OddNumber = 1
+Acount = 0
+DSum = 0
+PRINT "The first 25 abundant odd numbers:"
+DO WHILE Acount < 25
+ DSum = DivisorSum&(OddNumber)
+ IF DSum > OddNumber THEN
+ Acount = Acount + 1
+ PRINT USING "######"; OddNumber;
+ PRINT " proper divisor sum: ";
+ PRINT USING "######"; DSum
+ END IF
+ OddNumber = OddNumber + 2
+LOOP
+' 1000th odd abundant number
+DO WHILE Acount < 1000
+ DSum = DivisorSum&(OddNumber)
+ IF DSum > OddNumber THEN Acount = Acount + 1
+ OddNumber = OddNumber + 2
+LOOP
+PRINT "1000th abundant odd number:"
+PRINT " "; OddNumber - 2; "proper divisor sum:"; DSum
+' first odd abundant number > 1000000000
+OddNumber = 1000000001
+Found = FALSE%
+DO WHILE NOT Found
+ DSum = DivisorSum&(OddNumber)
+ IF DSum > OddNumber THEN
+ Found = TRUE%
+ PRINT "First abundant odd number > 1 000 000 000:"
+ PRINT " "; OddNumber; "proper divisor sum:"; DSum
+ END IF
+ OddNumber = OddNumber + 2
+LOOP
+END
+
+FUNCTION DivisorSum& (N AS LONG)
+DIM D AS LONG, OtherD AS LONG, Sum AS LONG
+Sum = 1
+FOR D = 2 TO INT(SQR(N))
+ IF N MOD D = 0 THEN
+ Sum = Sum + D
+ OtherD = N \ D
+ IF OtherD <> D THEN Sum = Sum + OtherD
+ END IF
+NEXT D
+DivisorSum& = Sum
+END FUNCTION
diff --git a/Task/Abundant-odd-numbers/Rebol/abundant-odd-numbers.rebol b/Task/Abundant-odd-numbers/Rebol/abundant-odd-numbers.rebol
new file mode 100644
index 0000000000..58cb640fe0
--- /dev/null
+++ b/Task/Abundant-odd-numbers/Rebol/abundant-odd-numbers.rebol
@@ -0,0 +1,51 @@
+Rebol [
+ title: "Rosetta code: Abundant odd numbers"
+ file: %Abundant_odd_numbers.r3
+ url: https://rosettacode.org/wiki/Abundant_odd_numbers
+ needs: 3.20.0 ;; because of the `prime?` native used
+ ;@@ https://github.com/Oldes/Rebol3/discussions/140
+]
+
+sum-proper-divisors: function[
+ "Compute the sum of proper divisors of n"
+ n [number!]
+][
+ db: clear [] ;; List to store divisors
+ ;; Iterate divisors up to sqrt(n)
+ for div 1 to integer! square-root n 1 [
+ if zero? n % div [ ;; If div divides n exactly
+ append db div ;; Add the divisor
+ append db n / div ;; Add the paired divisor
+ ]
+ ]
+ ;; Sum unique divisors and exclude the number itself
+ (sum unique db) - n
+]
+
+billion: 1'000'000'000 ;; One billion constant
+n: ix: 1 ;; Initialize current number and index
+
+print "The first 25 abundant odd numbers:"
+
+forever [
+ n: n + 2 ;; Move to the next odd number
+ if prime? n [continue] ;; Skip primes (never abundant)
+ prop-div: sum-proper-divisors n ;; Calculate proper divisor sum
+ if prop-div <= n [continue] ;; Not abundant if sum ≤ n
+
+ ;; Handle reporting for milestones and early results
+ case [
+ ix <= 25 [
+ print [pad n -5 ":" prop-div] ;; List first 25 found
+ ]
+ ix = 1000 [
+ print ["1000th abundant odd number:" n ":" prop-div]
+ n: billion + 1 ;; Skip ahead
+ ]
+ n > billion [
+ print ["First abundant odd number > 1'000'000'000:" n ":" prop-div]
+ break ;; Exit after this milestone
+ ]
+ ]
+ ++ ix ;; Increment index of abundant odd numbers found
+]
diff --git a/Task/Abundant-odd-numbers/Uiua/abundant-odd-numbers.uiua b/Task/Abundant-odd-numbers/Uiua/abundant-odd-numbers.uiua
new file mode 100644
index 0000000000..311e18169e
--- /dev/null
+++ b/Task/Abundant-odd-numbers/Uiua/abundant-odd-numbers.uiua
@@ -0,0 +1,7 @@
+AD ← ◴⊂⟜(⇌÷)▽⤚(=₀◿)⊸(↘1⇡+1⌊⊸√)
+DS ← /+↘¯1 AD
+⋅⇌⍢(+2⍥⟜⊂⊸<⊸DS|<1000⋅⧻)1 []
+⊃(⟜DS⊣|≡⊸DS↙25)
+
+⋅⇌⍢(+2⍥⟜⊂⊸<⊸DS|<1⋅⧻)+1 1e9 []
+⟜DS⊣
diff --git a/Task/Abundant-odd-numbers/VBA/abundant-odd-numbers.vba b/Task/Abundant-odd-numbers/VBA/abundant-odd-numbers.vba
new file mode 100644
index 0000000000..de6dd7e450
--- /dev/null
+++ b/Task/Abundant-odd-numbers/VBA/abundant-odd-numbers.vba
@@ -0,0 +1,63 @@
+' Abundant odd numbers
+
+Function DivisorSum(ByVal N As Long) As Long
+ ' Returns the sum of the proper divisors of N
+ Dim Sum As Long, D As Long, OtherD As Long
+ Sum = 1
+ For D = 2 To Int(Sqr(N))
+ If N Mod D = 0 Then
+ Sum = Sum + D
+ OtherD = N \ D
+ If OtherD <> D Then Sum = Sum + OtherD
+ End If
+ Next D
+ DivisorSum = Sum
+End Function
+
+Function FormatLong(ByVal Num As Long, L As Integer) As String
+ Dim S As String
+ S = Trim(Str(Num))
+ If Len(S) > L Then
+ FormatLong = String(L, "#")
+ Else
+ FormatLong = Right(String(L, " ") & S, L)
+ End If
+End Function
+
+Sub AbundantOddMain()
+ Dim OddNumber As Long, ACount As Long, DSum As Long
+ Dim Found As Boolean
+ ' first 25 odd abundant numbers
+ OddNumber = 1
+ ACount = 0
+ DSum = 0
+ Debug.Print "The first 25 abundant odd numbers:"
+ Do While ACount < 25
+ DSum = DivisorSum(OddNumber)
+ If DSum > OddNumber Then
+ ACount = ACount + 1
+ Debug.Print FormatLong(OddNumber, 6) & " proper divisor sum: " & FormatLong(DSum, 6)
+ End If
+ OddNumber = OddNumber + 2
+ Loop
+ ' 1000th odd abundant number
+ Do While ACount < 1000
+ DSum = DivisorSum(OddNumber)
+ If DSum > OddNumber Then ACount = ACount + 1
+ OddNumber = OddNumber + 2
+ Loop
+ Debug.Print "1000th abundant odd number:"
+ Debug.Print " " & OddNumber - 2 & " proper divisor sum: " & DSum
+ ' first odd abundant number > 1000000000
+ OddNumber = 1000000001
+ Found = False
+ Do Until Found
+ DSum = DivisorSum(OddNumber)
+ If DSum > OddNumber Then
+ Found = True
+ Debug.Print "First abundant odd number > 1 000 000 000:"
+ Debug.Print " " & OddNumber & " proper divisor sum: " & DSum
+ End If
+ OddNumber = OddNumber + 2
+ Loop
+End Sub
diff --git a/Task/Accumulator-factory/Ada/accumulator-factory-1.adb b/Task/Accumulator-factory/Ada/accumulator-factory-1.adb
new file mode 100644
index 0000000000..7a2d4fde69
--- /dev/null
+++ b/Task/Accumulator-factory/Ada/accumulator-factory-1.adb
@@ -0,0 +1,11 @@
+with Accumulator;
+with Ada.Text_IO; use Ada.Text_IO;
+
+procedure Example is
+ package A is new Accumulator;
+ package B is new Accumulator;
+begin
+ Put_Line (Integer'Image (A.The_Function (5)));
+ Put_Line (Integer'Image (B.The_Function (3)));
+ Put_Line (Float'Image (A.The_Function (2.3)));
+end;
diff --git a/Task/Accumulator-factory/Ada/accumulator-factory-2.adb b/Task/Accumulator-factory/Ada/accumulator-factory-2.adb
new file mode 100644
index 0000000000..90f6fbbec0
--- /dev/null
+++ b/Task/Accumulator-factory/Ada/accumulator-factory-2.adb
@@ -0,0 +1,11 @@
+generic package Accumulator is
+
+-- This Ada generic package represents an accumulator factory.
+-- The required function is provided as The_Function.
+-- The first call to The_Function sets the initial value.
+-- (Marius Amado-Alves)
+
+ function The_Function (X : Integer) return Integer;
+ function The_Function (X : Integer) return Float;
+ function The_Function (X : Float) return Float;
+end;
diff --git a/Task/Accumulator-factory/Ada/accumulator-factory-3.adb b/Task/Accumulator-factory/Ada/accumulator-factory-3.adb
new file mode 100644
index 0000000000..4d3ccb7a5f
--- /dev/null
+++ b/Task/Accumulator-factory/Ada/accumulator-factory-3.adb
@@ -0,0 +1,64 @@
+package body Accumulator is
+
+-- The accumulator lives through three states. It is in Virgin_State
+-- before any use of The_Function. It changes to Integer_State or
+-- Float_State, according to the input type used. The accumulation is
+-- memorized in variable I or F, according to the state. Float_State,
+-- once reached, is never left. A Float output on an Integer_State is
+-- simply a conversion, sans effect on state. (Marius Amado-Alves)
+
+ type State_T is (Virgin_State, Integer_State, Float_State);
+ State : State_T := Virgin_State;
+ I : Integer;
+ F : Float;
+
+ function The_Function (X : Float) return Float is
+ begin
+ case State is
+ when Virgin_State =>
+ State := Float_State;
+ F := X;
+ return F;
+ when Integer_State =>
+ State := Float_State;
+ F := Float (I) + X;
+ return F;
+ when Float_State =>
+ F := F + X;
+ return F;
+ end case;
+ end;
+
+ function The_Function (X : Integer) return Float is
+ begin
+ case State is
+ when Virgin_State =>
+ State := Integer_State;
+ I := X;
+ return Float (I);
+ when Integer_State =>
+ I := I + X;
+ return Float (I);
+ when Float_State =>
+ F := F + Float (X);
+ return F;
+ end case;
+ end;
+
+ function The_Function (X : Integer) return Integer is
+ begin
+ case State is
+ when Virgin_State =>
+ State := Integer_State;
+ I := X;
+ return I;
+ when Integer_State =>
+ I := I + X;
+ return I;
+ when Float_State =>
+ F := F + Float (X);
+ return Integer (F);
+ end case;
+ end;
+
+end;
diff --git a/Task/Accumulator-factory/EMal/accumulator-factory.emal b/Task/Accumulator-factory/EMal/accumulator-factory.emal
index 0204d00a15..b0da805059 100644
--- a/Task/Accumulator-factory/EMal/accumulator-factory.emal
+++ b/Task/Accumulator-factory/EMal/accumulator-factory.emal
@@ -9,7 +9,7 @@ type Number allows int, real
type AccumulatorUsingNumber
fun foo ← fun by Number n
fun g ← Number by Number i
- return n += i
+ return n +← i
end
return g
end
@@ -26,7 +26,7 @@ fun foo ← fun by var n
checkType(n)
fun g ← var by var i
checkType(i)
- return n += i
+ return n +← i
end
return g
end
@@ -38,7 +38,7 @@ type Main
List solutions ← generic[AccumulatorUsingNumber, AccumulatorUsingVar]
for int i ← 0; i < solutions.length; ++i
generic solution ← solutions[i]
- writeLine("=== solution " + (i + 1) + " ===")
+ writeLine("[ solution " + (i + 1) + " ]")
fun x ← :solution.foo(1)
x(5)
:solution.foo(3)
diff --git a/Task/Accumulator-factory/Pluto/accumulator-factory.pluto b/Task/Accumulator-factory/Pluto/accumulator-factory.pluto
new file mode 100644
index 0000000000..5baa4348fd
--- /dev/null
+++ b/Task/Accumulator-factory/Pluto/accumulator-factory.pluto
@@ -0,0 +1,11 @@
+local function accumulator(acc)
+ return |n| -> do
+ acc += n
+ return acc
+ end
+end
+
+local x = accumulator(1)
+x(5)
+accumulator(3)
+print(x(2.3))
diff --git a/Task/Accumulator-factory/PowerShell/accumulator-factory-1.ps1 b/Task/Accumulator-factory/PowerShell/accumulator-factory-1.ps1
new file mode 100644
index 0000000000..9d6b0bc910
--- /dev/null
+++ b/Task/Accumulator-factory/PowerShell/accumulator-factory-1.ps1
@@ -0,0 +1,4 @@
+function Get-Accumulator ([double]$Start)
+{
+ {param([double]$Plus) return $script:Start += $Plus}.GetNewClosure()
+}
diff --git a/Task/Accumulator-factory/PowerShell/accumulator-factory-2.ps1 b/Task/Accumulator-factory/PowerShell/accumulator-factory-2.ps1
new file mode 100644
index 0000000000..35ce2c8ca6
--- /dev/null
+++ b/Task/Accumulator-factory/PowerShell/accumulator-factory-2.ps1
@@ -0,0 +1,3 @@
+$total = Get-Accumulator -Start 1
+& $total -Plus 5.0 | Out-Null
+& $total -Plus 2.3
diff --git a/Task/Accumulator-factory/Rebol/accumulator-factory-1.rebol b/Task/Accumulator-factory/Rebol/accumulator-factory-1.rebol
new file mode 100644
index 0000000000..0738505b60
--- /dev/null
+++ b/Task/Accumulator-factory/Rebol/accumulator-factory-1.rebol
@@ -0,0 +1,11 @@
+make-acc-gen: func [start-val] [
+ use [state] [
+ state: start-val
+ func [value] [
+ state: state + value
+ ]
+ ]
+]
+gen: make-acc-gen 1
+print gen 5 ;== 6
+print gen 2.3 ;== 8.3
diff --git a/Task/Accumulator-factory/Rebol/accumulator-factory-2.rebol b/Task/Accumulator-factory/Rebol/accumulator-factory-2.rebol
new file mode 100644
index 0000000000..02468d5450
--- /dev/null
+++ b/Task/Accumulator-factory/Rebol/accumulator-factory-2.rebol
@@ -0,0 +1,25 @@
+;; Define a generator function 'gen' with an optional refinement '/init'
+;; - 'value' is a required number passed to the function
+;; - '/init' is an optional refinement for initialization
+gen: function/with [value [number!] /init] [
+
+ ;; If '/init' refinement is used, initialize state and exit immediately
+ if init [
+ state: value ;; Set the initial state to the provided value
+ exit ;; Exit, so nothing else in the function is run
+ ]
+
+ ;; If not initializing, add 'value' to 'state'
+ state: state + value
+
+ ;; The function returns the new state each call
+][state: 0] ;; 'state' is a local variable, initialized once per definition (persistent closure)
+
+;; Initialize the 'state' value of gen to 1 by calling it with '/init'
+gen/init 1
+
+;; Call gen with 5: Adds 5 to state and prints the result (should print 6)
+print gen 5
+
+;; Call gen with 2.3: Adds 2.3 to state and prints the result (should print 8.3)
+print gen 2.3
diff --git a/Task/Accumulator-factory/Red/accumulator-factory.red b/Task/Accumulator-factory/Red/accumulator-factory.red
new file mode 100644
index 0000000000..9bceca4447
--- /dev/null
+++ b/Task/Accumulator-factory/Red/accumulator-factory.red
@@ -0,0 +1,15 @@
+Red [ "Accumulator factory - hinjolicious" ]
+
+; just a helper func to display informative output
+demo: function [s b] [print ["^/==" s "==^/^/" mold/only b "^/>>"] do b]
+
+demo "Accumulator" [
+foo: function [init] [
+ acc: init
+ closure [val][acc: acc + val]
+]
+x: foo 1
+print x 5 ; 6
+foo 3 ; no effect!
+print x 2.3 ; 8.3
+]
diff --git a/Task/Accumulator-factory/V-(Vlang)/accumulator-factory.v b/Task/Accumulator-factory/V-(Vlang)/accumulator-factory.v
new file mode 100644
index 0000000000..c799934393
--- /dev/null
+++ b/Task/Accumulator-factory/V-(Vlang)/accumulator-factory.v
@@ -0,0 +1,23 @@
+struct Generator {
+ mut:
+ a_n []f64
+}
+
+fn (mut gen Generator) generator(ir f64) fn (f64) f64 {
+ gen.a_n << ir
+ id := gen.a_n.len - 1
+ return fn (mut gen Generator, id int) fn (f64) f64 {
+ return fn [mut gen, id] (d f64) f64 {
+ gen.a_n[id] += d
+ return gen.a_n[id]
+ }
+ }(mut gen, id)
+}
+
+fn main() {
+ mut o_generator := Generator{}
+ accumulator := o_generator.generator(1)
+ println(accumulator(5))
+ o_generator.generator(3)
+ println(accumulator(2.3))
+}
diff --git a/Task/Accumulator-factory/VBScript/accumulator-factory-1.vbs b/Task/Accumulator-factory/VBScript/accumulator-factory-1.vbs
new file mode 100644
index 0000000000..0973ec6443
--- /dev/null
+++ b/Task/Accumulator-factory/VBScript/accumulator-factory-1.vbs
@@ -0,0 +1,10 @@
+class accumulator
+ dim A
+ public default function acc(x)
+ A = A + x
+ acc = A
+ end function
+ public property get accum
+ accum = A
+ end property
+end class
diff --git a/Task/Accumulator-factory/VBScript/accumulator-factory-2.vbs b/Task/Accumulator-factory/VBScript/accumulator-factory-2.vbs
new file mode 100644
index 0000000000..c61351aaad
--- /dev/null
+++ b/Task/Accumulator-factory/VBScript/accumulator-factory-2.vbs
@@ -0,0 +1,8 @@
+dim a
+set a = new accumulator
+x = a( 1 )
+a 5
+dim b
+set b = new accumulator
+b 3
+wscript.echo a(2.3)
diff --git a/Task/Achilles-numbers/Ada/achilles-numbers.adb b/Task/Achilles-numbers/Ada/achilles-numbers.adb
new file mode 100644
index 0000000000..054f448da3
--- /dev/null
+++ b/Task/Achilles-numbers/Ada/achilles-numbers.adb
@@ -0,0 +1,205 @@
+pragma Ada_2022;
+
+with Ada.Text_IO;
+with Ada.Numerics; use Ada.Numerics;
+with Ada.Numerics.Long_Elementary_Functions;
+use Ada.Numerics.Long_Elementary_Functions;
+with Ada.Strings; use Ada.Strings;
+with Ada.Strings.Fixed; use Ada.Strings.Fixed;
+with Prime_Numbers;
+
+procedure Achilles_Numbers is
+
+ package Long_Integer_Prime_Numbers is new Prime_Numbers
+ (Integer, 0, 1, 2);
+ use Long_Integer_Prime_Numbers;
+
+ -- A powerful number N is such that for every primer factor P of it
+ -- P^2 also divides N
+ -- Is_Powerful function decomposes the given number N in its prime factors
+ -- and then it checks if each factor squared is a divisor of N
+ function Is_Powerful (Number : Natural) return Boolean is
+ List : constant Number_List := Decompose (Integer (Number));
+ begin
+ for Index in List'Range loop
+ declare
+ N : constant Long_Long_Integer := Long_Long_Integer (Number);
+ F : constant Long_Long_Integer := Long_Long_Integer (List (Index));
+ begin
+ if N mod (F * F) /= 0 then
+ return False;
+ end if;
+ end;
+ end loop;
+
+ return True;
+ end Is_Powerful;
+
+ -- The Is_Power function checks if a given number N can be written
+ -- as a power of two integers that are > 1
+ -- It makes use of the mathematical expression N = A^B
+ -- taking Log(N) = Log (A^B) equals to B = Log (N) / Log (A)
+ -- where the solutions are when B is an integer > 1
+ function Is_Power (N : Integer) return Boolean is
+
+ function Is_Almost_Equal (A : Long_Float;
+ B : Long_Float) return Boolean is
+ Epsilon : constant := 0.000_000_000_000_001;
+ begin
+ if abs (A - B) < Epsilon then
+ return True;
+ else
+ return False;
+ end if;
+ end Is_Almost_Equal;
+
+ A : Integer := 2;
+ B : Long_Float;
+ Log_Of_N : constant Long_Float := Log (Long_Float (N), 2.0);
+ begin
+ if N = 1 then
+ return True;
+ end if;
+
+ while True loop
+ B := Log_Of_N / Log (Long_Float (A), 2.0);
+
+ if Is_Almost_Equal (B, Long_Float (Integer (B)))
+ and then Integer (B) > 1
+ then
+ return True;
+ end if;
+
+ exit when A * A > N;
+ A := @ + 1;
+ end loop;
+
+ return False;
+
+ end Is_Power;
+
+ -- An Achilles number is a powerful number that can't be expressed
+ -- as a power
+ function Is_Achilles (N : Integer) return Boolean is
+ begin
+ if Is_Powerful (N) then
+ if Is_Power (N) = False then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Is_Achilles;
+
+ -- Calculates the Euler totient of a number
+ function Totient (N : Integer) return Integer is
+ Tot : Integer := N;
+ I : Integer;
+ N2 : Integer := N;
+ begin
+ I := 2;
+ while I * I <= N2 loop
+ if N2 mod I = 0 then
+ while N2 mod I = 0 loop
+ N2 := N2 / I;
+ end loop;
+ Tot := Tot - Tot / I;
+ end if;
+
+ if I = 2 then
+ I := 1;
+ end if;
+ I := I + 2;
+ end loop;
+
+ if N2 > 1 then
+ Tot := Tot - Tot / N2;
+ end if;
+
+ return Tot;
+ end Totient;
+
+ -- A Strong Achilles number is an Achilles number whose Euler Totient
+ -- is also an Achilles number
+ function Is_Strong_Achilles (N : Integer) return Boolean is
+ begin
+ if Is_Achilles (N) then
+ if Is_Achilles (Totient (N)) then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Is_Strong_Achilles;
+
+ -- Counts the digits in a number by taking the string from
+ -- its 'Image attribute, trimming it and counting the characters
+ function Count_Digits (N : Integer) return Natural is
+ Integer_Str : constant String := Trim (N'Image, Both);
+ begin
+ return Integer_Str'Length;
+ end Count_Digits;
+
+begin
+ -- Find the first 50 Achilles numbers
+ declare
+ N : Integer := 1;
+ Count : Integer := 1;
+ begin
+ Ada.Text_IO.Put_Line ("First 50 Achilles numbers:");
+
+ while Count <= 50 loop
+
+ if Is_Achilles (N) then
+ Count := @ + 1;
+ Ada.Text_IO.Put (N'Image & " ");
+ end if;
+
+ N := @ + 1;
+ end loop;
+
+ Ada.Text_IO.New_Line;
+ end;
+
+ -- Find the first 20 Strong Achilles numbers
+ declare
+ N : Integer := 1;
+ Count : Integer := 1;
+ begin
+ Ada.Text_IO.Put_Line ("First 20 Strong Achilles numbers:");
+
+ while Count <= 20 loop
+
+ if Is_Strong_Achilles (N) then
+ Count := @ + 1;
+ Ada.Text_IO.Put (N'Image & " ");
+ end if;
+
+ N := @ + 1;
+ end loop;
+
+ Ada.Text_IO.New_Line;
+ end;
+
+ -- Count numbers with digits
+ declare
+ Counts : array (2 .. 6) of Natural := [others => 0];
+ N : Integer := 1;
+ begin
+ Ada.Text_IO.Put_Line ("Number of Achilles numbers with:");
+
+ while Count_Digits (N) <= Counts'Last loop
+
+ -- Ada.Text_IO.Put_Line ("Testing: " & N'Image);
+
+ if Is_Achilles (N) then
+ Counts (Count_Digits (N)) := @ + 1;
+ end if;
+ N := @ + 1;
+ end loop;
+
+ for I in Counts'Range loop
+ Ada.Text_IO.Put_Line (I'Image & " digits: " & Counts (I)'Image);
+ end loop;
+ end;
+end Achilles_Numbers;
diff --git a/Task/Achilles-numbers/Arturo/achilles-numbers.arturo b/Task/Achilles-numbers/Arturo/achilles-numbers.arturo
new file mode 100644
index 0000000000..939ef41b2a
--- /dev/null
+++ b/Task/Achilles-numbers/Arturo/achilles-numbers.arturo
@@ -0,0 +1,36 @@
+prettyPrint: function [res][
+ res | split.every: 10
+ | loop => [print map & 'x -> pad to :string x 7]
+]
+
+achilles?: function [n][
+ exps: values tally factors.prime n
+ and? -> not? some? exps => one?
+ -> 1 = fold exps [a b] -> gcd @[a b]
+]
+
+phi: function [n][
+ pf: tally factors.prime n
+ fold.seed:1 keys pf [res pr][
+ ipr: to :integer pr
+ res * (ipr - 1) * ipr ^ dec to :integer pf\[ipr]
+ ]
+]
+
+n: 50
+print ["First" n "Achilles numbers:"]
+2..∞ | select.first: n => achilles?
+ | prettyPrint
+
+print ""
+print ["First" n "strong Achilles numbers:"]
+2..∞ | select.first: n 'x -> and? [achilles? x][achilles? phi x]
+ | prettyPrint
+
+print ""
+counts: 2..1000000 | select => achilles?
+ | map => [size digits &]
+ | tally
+
+loop counts [k v]->
+ print [k "digits:" v]
diff --git a/Task/Achilles-numbers/C/achilles-numbers.c b/Task/Achilles-numbers/C/achilles-numbers.c
new file mode 100644
index 0000000000..f7ed293f8e
--- /dev/null
+++ b/Task/Achilles-numbers/C/achilles-numbers.c
@@ -0,0 +1,105 @@
+#include
+#include
+#include
+#include
+
+bool is_prime(int n) {
+ if (n < 2) return false;
+ if (n % 2 == 0 && n != 2) return false;
+ for (int i = 3; i <= sqrt(n); i += 2) {
+ if (n % i == 0) return false;
+ }
+ return true;
+}
+
+int phi(int n) {
+ int result = n;
+ for (int p = 2; p * p <= n; p++) {
+ if (n % p == 0) {
+ while (n % p == 0) n /= p;
+ result -= result / p;
+ }
+ }
+ if (n > 1) result -= result / n;
+ return result;
+}
+
+bool is_powerful(int n) {
+ int m = n;
+ for (int p = 2; p * p <= n; p++) {
+ if (m % p == 0) {
+ int exp = 0;
+ while (m % p == 0) {
+ m /= p;
+ exp++;
+ }
+ if (exp < 2) return false;
+ }
+ }
+ if (m > 1) return false;
+ return true;
+}
+
+bool is_perfect_power(int n) {
+ for (int k = 2; k <= log2(n); k++) {
+ double root = pow(n, 1.0 / k);
+ int r = round(root);
+ if (pow(r, k) == n) return true;
+ }
+ return false;
+}
+
+bool is_achilles(int n) {
+ return is_powerful(n) && !is_perfect_power(n);
+}
+
+int main() {
+ int *achilles = NULL, *strong = NULL;
+ int a_count = 0, s_count = 0;
+ int digit_counts[7] = {0};
+
+ for (int n = 2; a_count < 50 || s_count < 50; n++) {
+ if (is_achilles(n)) {
+ if (a_count < 50){
+ achilles = realloc(achilles, (a_count+1)*sizeof(int));
+ achilles[a_count++] = n;
+ }
+
+ int ph = phi(n);
+ if (is_achilles(ph)) {
+ if (s_count < 50){
+ strong = realloc(strong, (s_count+1)*sizeof(int));
+ strong[s_count++] = n;
+ }
+ }
+
+ }
+ }
+
+ for (int n = 2; n <= 1000000; n++) {
+ if (is_achilles(n)) {
+ int digits = floor(log10(n)) + 1;
+ if (digits >= 2 && digits <= 15) {
+ digit_counts[digits]++;
+ }
+ }
+ }
+
+ printf("First 50 Achilles numbers:\n");
+ for (int i = 0; i < 50; i++) {
+ printf("%d ", achilles[i]);
+ }
+ printf("\n\n");
+
+ printf("First 50 Strong Achilles numbers:\n");
+ for (int i = 0; i < 50; i++) {
+ printf("%d ", strong[i]);
+ }
+ printf("\n\n");
+
+ for (int d = 2; d <= 6; d++) {
+ printf("Achilles numbers with %d digits: %d\n", d, digit_counts[d]);
+ }
+
+ return 0;
+}
diff --git a/Task/Achilles-numbers/COBOL/achilles-numbers.cob b/Task/Achilles-numbers/COBOL/achilles-numbers.cob
new file mode 100644
index 0000000000..f5fdc87beb
--- /dev/null
+++ b/Task/Achilles-numbers/COBOL/achilles-numbers.cob
@@ -0,0 +1,257 @@
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. ACHILLES-NUMBERS.
+
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 CONSTANTS.
+ 05 MAX-LIMIT PIC 9(10) COMP VALUE 100000000.
+ 05 MAX-LIMIT-SQR PIC 9(6) COMP VALUE 10000.
+ 05 MAX-LIMIT-CUB PIC 9(6) COMP VALUE 464.
+
+ 01 PP-TEMP-DATA.
+ 05 PP-TEMP-COUNT PIC 9(6) COMP VALUE 0.
+ 05 PP-TEMP-TABLE.
+ 10 PP-TEMP OCCURS 1 TO 15000 TIMES DEPENDING ON PP-TEMP-COUNT
+ ASCENDING KEY IS PP-TEMP
+ PIC 9(10) COMP.
+
+ 01 PP-FINAL-DATA.
+ 05 PP-COUNT PIC 9(6) COMP VALUE 0.
+ 05 PP-TABLE.
+ 10 P-POWER OCCURS 1 TO 15000 TIMES DEPENDING ON PP-COUNT
+ ASCENDING KEY IS P-POWER
+ INDEXED BY PP-IDX
+ PIC 9(10) COMP.
+
+ 01 ACH-TEMP-DATA.
+ 05 ACH-TEMP-COUNT PIC 9(6) COMP VALUE 0.
+ 05 ACH-TEMP-TABLE.
+ 10 ACH-TEMP OCCURS 1 TO 35000 TIMES DEPENDING ON ACH-TEMP-COUNT
+ ASCENDING KEY IS ACH-TEMP
+ PIC 9(10) COMP.
+
+ 01 ACH-FINAL-DATA.
+ 05 ACH-COUNT PIC 9(6) COMP VALUE 0.
+ 05 ACH-TABLE.
+ 10 ACHILLES OCCURS 1 TO 15000 TIMES DEPENDING ON ACH-COUNT
+ ASCENDING KEY IS ACHILLES
+ INDEXED BY ACH-IDX
+ PIC 9(10) COMP.
+
+ 01 LOOP-VARS.
+ 05 I PIC 9(6) COMP.
+ 05 B PIC 9(6) COMP.
+ 05 A PIC 9(6) COMP.
+ 05 LAST-VAL PIC 9(10) COMP.
+
+ 01 CALC-VARS.
+ 05 P PIC 9(18) COMP.
+ 05 B3 PIC 9(18) COMP.
+ 05 SEARCH-P PIC 9(10) COMP.
+
+ 01 TOT-VARS.
+ 05 TOTIENT-IN PIC 9(10) COMP.
+ 05 TOTIENT-OUT PIC 9(10) COMP.
+ 05 TOT-I PIC 9(10) COMP.
+ 05 TOT-N PIC 9(10) COMP.
+ 05 TOT-Q PIC 9(10) COMP.
+ 05 TOT-R PIC 9(10) COMP.
+ 05 SUB-VAL PIC 9(10) COMP.
+
+ 01 STRONG-ACH-VARS.
+ 05 FOUND-FLAG PIC 9 VALUE 0.
+ 05 STRONG-COUNT PIC 9(4) COMP VALUE 0.
+ 05 STRONG-ACH OCCURS 30 TIMES PIC 9(10) COMP.
+
+ 01 REPORT-VARS.
+ 05 DISP-4 PIC ZZZ9.
+ 05 DISP-5 PIC ZZZZ9.
+ 05 DISP-2 PIC Z9.
+ 05 DISP-NUM PIC Z(9)9.
+ 05 FORMATTED-LINE PIC X(60) VALUE SPACES.
+ 05 LINE-POS PIC 9(4) COMP VALUE 1.
+ 05 ROW-COUNT PIC 9(4) COMP VALUE 0.
+ 05 DIGIT-COUNT PIC 9(10) COMP.
+ 05 D PIC 9(2) COMP.
+ 05 LOWER-BND PIC 9(10) COMP.
+ 05 UPPER-BND PIC 9(10) COMP.
+
+ PROCEDURE DIVISION.
+ MAIN-PARA.
+ PERFORM GENERATE-PERFECT-POWERS.
+ PERFORM GENERATE-ACHILLES.
+ PERFORM PRINT-FIRST-50.
+ PERFORM PRINT-STRONG-30.
+ PERFORM PRINT-DIGITS.
+ STOP RUN.
+
+ GENERATE-PERFECT-POWERS.
+ MOVE 0 TO PP-TEMP-COUNT.
+ PERFORM VARYING I FROM 2 BY 1 UNTIL I > MAX-LIMIT-SQR
+ COMPUTE P = I * I
+ PERFORM UNTIL P >= MAX-LIMIT
+ ADD 1 TO PP-TEMP-COUNT
+ MOVE P TO PP-TEMP(PP-TEMP-COUNT)
+ COMPUTE P = P * I
+ END-PERFORM
+ END-PERFORM.
+
+ SORT PP-TEMP ON ASCENDING KEY PP-TEMP.
+
+ MOVE 0 TO PP-COUNT.
+ MOVE 0 TO LAST-VAL.
+ PERFORM VARYING I FROM 1 BY 1 UNTIL I > PP-TEMP-COUNT
+ IF PP-TEMP(I) NOT = LAST-VAL THEN
+ ADD 1 TO PP-COUNT
+ MOVE PP-TEMP(I) TO P-POWER(PP-COUNT)
+ MOVE PP-TEMP(I) TO LAST-VAL
+ END-IF
+ END-PERFORM.
+
+ GENERATE-ACHILLES.
+ MOVE 0 TO ACH-TEMP-COUNT.
+ PERFORM VARYING B FROM 1 BY 1 UNTIL B > MAX-LIMIT-CUB
+ COMPUTE B3 = B * B * B
+ PERFORM VARYING A FROM 1 BY 1 UNTIL A > MAX-LIMIT-SQR
+ COMPUTE P = B3 * A * A
+ IF P >= MAX-LIMIT THEN
+ EXIT PERFORM
+ END-IF
+
+ IF P > 1 THEN
+ MOVE P TO SEARCH-P
+ MOVE 0 TO FOUND-FLAG
+ SEARCH ALL P-POWER
+ AT END
+ MOVE 0 TO FOUND-FLAG
+ WHEN P-POWER(PP-IDX) = SEARCH-P
+ MOVE 1 TO FOUND-FLAG
+ END-SEARCH
+
+ IF FOUND-FLAG = 0 THEN
+ ADD 1 TO ACH-TEMP-COUNT
+ MOVE P TO ACH-TEMP(ACH-TEMP-COUNT)
+ END-IF
+ END-IF
+ END-PERFORM
+ END-PERFORM.
+
+ SORT ACH-TEMP ON ASCENDING KEY ACH-TEMP.
+
+ MOVE 0 TO ACH-COUNT.
+ MOVE 0 TO LAST-VAL.
+ PERFORM VARYING I FROM 1 BY 1 UNTIL I > ACH-TEMP-COUNT
+ IF ACH-TEMP(I) NOT = LAST-VAL THEN
+ ADD 1 TO ACH-COUNT
+ MOVE ACH-TEMP(I) TO ACHILLES(ACH-COUNT)
+ MOVE ACH-TEMP(I) TO LAST-VAL
+ END-IF
+ END-PERFORM.
+
+ CALC-TOTIENT.
+ MOVE TOTIENT-IN TO TOT-N
+ MOVE TOTIENT-IN TO TOTIENT-OUT
+ MOVE 2 TO TOT-I
+ PERFORM UNTIL TOT-I * TOT-I > TOT-N
+ DIVIDE TOT-N BY TOT-I GIVING TOT-Q REMAINDER TOT-R
+ IF TOT-R = 0 THEN
+ PERFORM UNTIL TOT-R NOT = 0
+ DIVIDE TOT-N BY TOT-I GIVING TOT-Q REMAINDER TOT-R
+ IF TOT-R = 0 THEN
+ MOVE TOT-Q TO TOT-N
+ END-IF
+ END-PERFORM
+ DIVIDE TOTIENT-OUT BY TOT-I GIVING SUB-VAL
+ SUBTRACT SUB-VAL FROM TOTIENT-OUT
+ END-IF
+ IF TOT-I = 2 THEN
+ MOVE 1 TO TOT-I
+ END-IF
+ ADD 2 TO TOT-I
+ END-PERFORM.
+ IF TOT-N > 1 THEN
+ DIVIDE TOTIENT-OUT BY TOT-N GIVING SUB-VAL
+ SUBTRACT SUB-VAL FROM TOTIENT-OUT
+ END-IF.
+
+ PRINT-FIRST-50.
+ DISPLAY "First 50 Achilles numbers:".
+ MOVE SPACES TO FORMATTED-LINE.
+ MOVE 1 TO LINE-POS.
+ MOVE 0 TO ROW-COUNT.
+ PERFORM VARYING I FROM 1 BY 1 UNTIL I > 50
+ MOVE ACHILLES(I) TO DISP-4
+ STRING DISP-4 " " DELIMITED BY SIZE
+ INTO FORMATTED-LINE WITH POINTER LINE-POS
+ ADD 1 TO ROW-COUNT
+ IF ROW-COUNT = 10 THEN
+ DISPLAY FORMATTED-LINE(1:LINE-POS - 1)
+ MOVE SPACES TO FORMATTED-LINE
+ MOVE 1 TO LINE-POS
+ MOVE 0 TO ROW-COUNT
+ END-IF
+ END-PERFORM.
+
+ PRINT-STRONG-30.
+ DISPLAY " ".
+ DISPLAY "First 30 strong Achilles numbers:".
+ MOVE 0 TO STRONG-COUNT.
+ PERFORM VARYING I FROM 1 BY 1 UNTIL STRONG-COUNT >= 30 OR I > ACH-COUNT
+ MOVE ACHILLES(I) TO TOTIENT-IN
+ PERFORM CALC-TOTIENT
+
+ MOVE TOTIENT-OUT TO SEARCH-P
+ MOVE 0 TO FOUND-FLAG
+ SEARCH ALL ACHILLES
+ AT END
+ MOVE 0 TO FOUND-FLAG
+ WHEN ACHILLES(ACH-IDX) = SEARCH-P
+ MOVE 1 TO FOUND-FLAG
+ END-SEARCH
+
+ IF FOUND-FLAG = 1 THEN
+ ADD 1 TO STRONG-COUNT
+ MOVE ACHILLES(I) TO STRONG-ACH(STRONG-COUNT)
+ END-IF
+ END-PERFORM.
+
+ MOVE SPACES TO FORMATTED-LINE.
+ MOVE 1 TO LINE-POS.
+ MOVE 0 TO ROW-COUNT.
+ PERFORM VARYING I FROM 1 BY 1 UNTIL I > 30
+ MOVE STRONG-ACH(I) TO DISP-5
+ STRING DISP-5 " " DELIMITED BY SIZE
+ INTO FORMATTED-LINE WITH POINTER LINE-POS
+ ADD 1 TO ROW-COUNT
+ IF ROW-COUNT = 10 THEN
+ DISPLAY FORMATTED-LINE(1:LINE-POS - 1)
+ MOVE SPACES TO FORMATTED-LINE
+ MOVE 1 TO LINE-POS
+ MOVE 0 TO ROW-COUNT
+ END-IF
+ END-PERFORM.
+
+ PRINT-DIGITS.
+ DISPLAY " ".
+ DISPLAY "Number of Achilles numbers with:".
+ MOVE 10 TO LOWER-BND.
+ COMPUTE UPPER-BND = 100.
+ PERFORM VARYING D FROM 2 BY 1 UNTIL D > 8
+ MOVE 0 TO DIGIT-COUNT
+ PERFORM VARYING I FROM 1 BY 1 UNTIL I > ACH-COUNT
+ IF ACHILLES(I) >= UPPER-BND THEN
+ EXIT PERFORM
+ END-IF
+ IF ACHILLES(I) >= LOWER-BND THEN
+ ADD 1 TO DIGIT-COUNT
+ END-IF
+ END-PERFORM
+
+ MOVE D TO DISP-2
+ MOVE DIGIT-COUNT TO DISP-NUM
+
+ DISPLAY DISP-2 " digits: " FUNCTION TRIM(DISP-NUM)
+
+ MOVE UPPER-BND TO LOWER-BND
+ COMPUTE UPPER-BND = UPPER-BND * 10
+ END-PERFORM.
diff --git a/Task/Achilles-numbers/Crystal/achilles-numbers.cr b/Task/Achilles-numbers/Crystal/achilles-numbers.cr
new file mode 100644
index 0000000000..2cb66173f9
--- /dev/null
+++ b/Task/Achilles-numbers/Crystal/achilles-numbers.cr
@@ -0,0 +1,86 @@
+struct Int
+ def totient
+ n = self
+ return 0 if n < 1
+ tot = n
+ i = typeof(n).new(2)
+ while i*i <= n
+ if n % i == 0
+ while n % i == 0
+ n //= i
+ end
+ tot -= tot // i
+ end
+ if i == 2; i = 1 end
+ i += 2
+ end
+ if n > 1
+ tot -= tot // n
+ end
+ tot
+ end
+end
+
+def get_perfect_powers (max_exp)
+ upper = 10_u64 ** max_exp
+ pps = Set(UInt64).new
+ (2_u64 .. Math.isqrt(upper)).each do |i|
+ p = i
+ while (p *= i) < upper
+ pps << p
+ end
+ end
+ pps
+end
+
+def get_achilles (min_exp, max_exp, pps)
+ lower = 10_u64 ** min_exp
+ upper = 10_u64 ** max_exp
+ achilles = Set(UInt64).new
+ (1_u64 .. Math.cbrt(upper).to_u64).each do |b|
+ b3 = b * b * b
+ (1_u64 .. Math.isqrt(upper)).each do |a|
+ p = b3 * a * a
+ break if p >= upper
+ if p >= lower
+ achilles << p unless p.in? pps
+ end
+ end
+ end
+ achilles
+end
+
+def tprint (fmt, seq, row_sz)
+ seq.in_slices_of(row_sz).each do |slice|
+ puts slice.map {|elt| fmt % { elt } }.join(" ")
+ end
+end
+
+max_digits = 12
+pps = get_perfect_powers(max_digits)
+
+achilles_set = get_achilles(1, 5, pps)
+achilles = achilles_set.to_a.sort!
+
+puts "First 50 Achilles numbers:"
+tprint("%4d", achilles.first(50), 10)
+
+puts "\nFirst 30 strong Achilles numbers:"
+strong_achilles = [] of UInt64
+count = 0
+n = 0
+while count < 30
+ tot = achilles[n].totient
+ if tot.in? achilles_set
+ strong_achilles << achilles[n]
+ count += 1
+ end
+ n += 1
+end
+tprint("%5d", strong_achilles, 10)
+
+puts "\nNumber of Achilles numbers with:"
+(2..max_digits).each do |d|
+ ac = get_achilles(d-1, d, pps).size
+ puts "%2d digits: %d" % { d, ac }
+end
diff --git a/Task/Achilles-numbers/JavaScript/achilles-numbers.js b/Task/Achilles-numbers/JavaScript/achilles-numbers.js
new file mode 100644
index 0000000000..3f0113554c
--- /dev/null
+++ b/Task/Achilles-numbers/JavaScript/achilles-numbers.js
@@ -0,0 +1,129 @@
+class AchillesNumbers {
+ constructor() {
+ this.pps = new Map(); // Stores perfect powers
+ }
+
+ // Euler's totient function
+ totient(n) {
+ let tot = n;
+ let i = 2;
+ while (i * i <= n) {
+ if (n % i === 0) {
+ // Remove all factors of i
+ while (n % i === 0) {
+ n = Math.floor(n / i);
+ }
+ tot -= Math.floor(tot / i);
+ }
+ // Handle even/odd step correctly
+ if (i === 2) {
+ i = 1;
+ }
+ i += 2;
+ }
+ // If remaining n is a prime
+ if (n > 1) {
+ tot -= Math.floor(tot / n);
+ }
+ return tot;
+ }
+
+ // Generate all perfect powers up to 10^maxExp
+ getPerfectPowers(maxExp) {
+ const upper = Math.pow(10, maxExp);
+ const sqrtUpper = Math.floor(Math.sqrt(upper));
+
+ for (let i = 2; i <= sqrtUpper; i++) {
+ let p = i;
+ while (true) {
+ p *= i;
+ if (p >= upper) break;
+ this.pps.set(Math.floor(p), true);
+ }
+ }
+ }
+
+ // Generate all Achilles numbers between 10^minExp and 10^maxExp
+ getAchilles(minExp, maxExp) {
+ const lower = Math.pow(10, minExp);
+ const upper = Math.pow(10, maxExp);
+ const achilles = new Map();
+
+ const cbrtUpper = Math.floor(Math.cbrt(upper));
+ for (let b = 1; b <= cbrtUpper; b++) {
+ const b3 = b * b * b;
+ const sqrtUpper = Math.floor(Math.sqrt(upper));
+
+ for (let a = 1; a <= sqrtUpper; a++) {
+ const p = b3 * a * a;
+ if (p >= upper) break;
+
+ if (p >= lower) {
+ if (!this.pps.has(p)) {
+ achilles.set(p, true);
+ }
+ }
+ }
+ }
+ return achilles;
+ }
+
+ static main() {
+ const an = new AchillesNumbers();
+ const maxDigits = 8;
+
+ an.getPerfectPowers(maxDigits);
+ const achillesSet = an.getAchilles(1, 5);
+
+ // Convert map keys to sorted array
+ const achilles = Array.from(achillesSet.keys()).sort((a, b) => a - b);
+
+ // Print first 50 Achilles numbers
+ console.log("First 50 Achilles numbers:");
+ let output = "";
+ for (let i = 0; i < 50; i++) {
+ output += `${achilles[i].toString().padStart(4)} `;
+ if ((i + 1) % 10 === 0) {
+ console.log(output);
+ output = "";
+ }
+ }
+ if (output) console.log(output);
+
+ // Print first 30 strong Achilles numbers
+ console.log("\nFirst 30 strong Achilles numbers:");
+ const strongAchilles = [];
+ let count = 0;
+ let idx = 0;
+
+ while (count < 30 && idx < achilles.length) {
+ const n = achilles[idx];
+ const tot = an.totient(n);
+ if (achillesSet.has(tot)) {
+ strongAchilles.push(n);
+ count++;
+ }
+ idx++;
+ }
+
+ output = "";
+ for (let i = 0; i < 30; i++) {
+ output += `${strongAchilles[i].toString().padStart(5)} `;
+ if ((i + 1) % 10 === 0) {
+ console.log(output);
+ output = "";
+ }
+ }
+ if (output) console.log(output);
+
+ // Print counts per digit length
+ console.log("\nNumber of Achilles numbers with:");
+ for (let d = 2; d <= maxDigits; d++) {
+ const ac = an.getAchilles(d - 1, d).size;
+ console.log(`${d.toString().padStart(2)} digits: ${ac}`);
+ }
+ }
+}
+
+// Execute the main method
+AchillesNumbers.main();
diff --git a/Task/Ackermann-function/Ada/ackermann-function.adb b/Task/Ackermann-function/Ada/ackermann-function.adb
new file mode 100644
index 0000000000..bbabde3783
--- /dev/null
+++ b/Task/Ackermann-function/Ada/ackermann-function.adb
@@ -0,0 +1,21 @@
+with Ada.Text_IO; use Ada.Text_IO;
+
+procedure Test_Ackermann is
+ function Ackermann (M, N : Natural) return Natural is
+ begin
+ if M = 0 then
+ return N + 1;
+ elsif N = 0 then
+ return Ackermann (M - 1, 1);
+ else
+ return Ackermann (M - 1, Ackermann (M, N - 1));
+ end if;
+ end Ackermann;
+begin
+ for M in 0..3 loop
+ for N in 0..6 loop
+ Put (Natural'Image (Ackermann (M, N)));
+ end loop;
+ New_Line;
+ end loop;
+end Test_Ackermann;
diff --git a/Task/Ackermann-function/Agena/ackermann-function.agena b/Task/Ackermann-function/Agena/ackermann-function.agena
new file mode 100644
index 0000000000..3a0a4d1c93
--- /dev/null
+++ b/Task/Ackermann-function/Agena/ackermann-function.agena
@@ -0,0 +1,39 @@
+scope # Ackermann function
+
+ proc ackermann( m :: number, n :: number ) :: number
+ feature reminisce; # create a remember table for this procedure
+ # it seems the procedure must be global for this statement
+ return if m = 0 then n + 1
+ elif m = 1 then n + 2 # expand some cases to avoid more
+ elif m = 2 then 3 + 2 * n # recursion - as in the Maple
+ elif m = 3 then 5 + 8 * ( 2 ^ n - 1 ) # Mathematica, etc. samples
+ elif n = 0 then ackermann( m - 1, 1 )
+ else ackermann( m - 1, ackermann( m, n - 1 ) )
+ fi
+ end;
+
+ local constant fmt := seq( " %1.0f", " %2.0f", " %2.0f", " %2.0f"
+ , " %3.0f", " %3.0f", " %3.0f", " %4.0f"
+ , " %4.0f", " %4.0f", " %4.0f", " %5.0f"
+ , " %5.0f", " %5.0f", " %6.0f", " %6.0f"
+ , " %6.0f", " %7.0f", " %7.0f", " %7.0f"
+ , " %7.0f", " %7.0f", " %7.0f", " %7.0f"
+ );
+ local constant maxN := 20;
+
+ printf( " n" );
+ for n from 0 to maxN do printf( fmt[ n + 1 ], n ) od;
+ print();
+ printf( " m+" );
+ for n from 0 to 18 do printf( "------", n ) od;
+ print();
+
+ for m from 0 to 3 do
+ printf( "%2d|", m );
+ for n from 0 to maxN do
+ printf( fmt[ n + 1 ], ackermann( m, n ) )
+ od;
+ print()
+ od
+
+end
diff --git a/Task/Ackermann-function/AutoIt/ackermann-function-1.au3 b/Task/Ackermann-function/AutoIt/ackermann-function-1.au3
new file mode 100644
index 0000000000..6fec759786
--- /dev/null
+++ b/Task/Ackermann-function/AutoIt/ackermann-function-1.au3
@@ -0,0 +1,11 @@
+Func Ackermann($m, $n)
+ If ($m = 0) Then
+ Return $n+1
+ Else
+ If ($n = 0) Then
+ Return Ackermann($m-1, 1)
+ Else
+ return Ackermann($m-1, Ackermann($m, $n-1))
+ EndIf
+ EndIf
+EndFunc
diff --git a/Task/Ackermann-function/AutoIt/ackermann-function-2.au3 b/Task/Ackermann-function/AutoIt/ackermann-function-2.au3
new file mode 100644
index 0000000000..f45c87f759
--- /dev/null
+++ b/Task/Ackermann-function/AutoIt/ackermann-function-2.au3
@@ -0,0 +1,18 @@
+Global $ackermann[2047][2047] ; Set the size to whatever you want
+Func Ackermann($m, $n)
+ If ($ackermann[$m][$n] <> 0) Then
+ Return $ackermann[$m][$n]
+ Else
+ If ($m = 0) Then
+ $return = $n + 1
+ Else
+ If ($n = 0) Then
+ $return = Ackermann($m - 1, 1)
+ Else
+ $return = Ackermann($m - 1, Ackermann($m, $n - 1))
+ EndIf
+ EndIf
+ $ackermann[$m][$n] = $return
+ Return $return
+ EndIf
+EndFunc ;==>Ackermann
diff --git a/Task/Ackermann-function/COBOL/ackermann-function.cob b/Task/Ackermann-function/COBOL/ackermann-function.cob
new file mode 100644
index 0000000000..8fafd91540
--- /dev/null
+++ b/Task/Ackermann-function/COBOL/ackermann-function.cob
@@ -0,0 +1,32 @@
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. Ackermann.
+
+ DATA DIVISION.
+ LINKAGE SECTION.
+ 01 M USAGE UNSIGNED-LONG.
+ 01 N USAGE UNSIGNED-LONG.
+
+ 01 Return-Val USAGE UNSIGNED-LONG.
+
+ PROCEDURE DIVISION USING M N Return-Val.
+ EVALUATE M ALSO N
+ WHEN 0 ALSO ANY
+ ADD 1 TO N GIVING Return-Val
+
+ WHEN NOT 0 ALSO 0
+ SUBTRACT 1 FROM M
+ CALL "Ackermann" USING BY CONTENT M BY CONTENT 1
+ BY REFERENCE Return-Val
+
+ WHEN NOT 0 ALSO NOT 0
+ SUBTRACT 1 FROM N
+ CALL "Ackermann" USING BY CONTENT M BY CONTENT N
+ BY REFERENCE Return-Val
+
+ SUBTRACT 1 FROM M
+ CALL "Ackermann" USING BY CONTENT M
+ BY CONTENT Return-Val BY REFERENCE Return-Val
+ END-EVALUATE
+
+ GOBACK
+ .
diff --git a/Task/Ackermann-function/Chapel/ackermann-function.chpl b/Task/Ackermann-function/Chapel/ackermann-function.chpl
new file mode 100644
index 0000000000..20b6590fc7
--- /dev/null
+++ b/Task/Ackermann-function/Chapel/ackermann-function.chpl
@@ -0,0 +1,8 @@
+proc A(m:int, n:int):int {
+ if m == 0 then
+ return n + 1;
+ else if n == 0 then
+ return A(m - 1, 1);
+ else
+ return A(m - 1, A(m, n - 1));
+}
diff --git a/Task/Ackermann-function/Emacs-Lisp/ackermann-function.el b/Task/Ackermann-function/Emacs-Lisp/ackermann-function.el
new file mode 100644
index 0000000000..cf6cce77b9
--- /dev/null
+++ b/Task/Ackermann-function/Emacs-Lisp/ackermann-function.el
@@ -0,0 +1,5 @@
+(defun ackermann (m n)
+ (cond ((zerop m) (1+ n))
+ ((zerop n) (ackermann (1- m) 1))
+ (t (ackermann (1- m)
+ (ackermann m (1- n))))))
diff --git a/Task/Ackermann-function/Euphoria/ackermann-function-1.eu b/Task/Ackermann-function/Euphoria/ackermann-function-1.eu
new file mode 100644
index 0000000000..cd4d6a4745
--- /dev/null
+++ b/Task/Ackermann-function/Euphoria/ackermann-function-1.eu
@@ -0,0 +1,16 @@
+function ack(atom m, atom n)
+ if m = 0 then
+ return n + 1
+ elsif m > 0 and n = 0 then
+ return ack(m - 1, 1)
+ else
+ return ack(m - 1, ack(m, n - 1))
+ end if
+end function
+
+for i = 0 to 3 do
+ for j = 0 to 6 do
+ printf( 1, "%5d", ack( i, j ) )
+ end for
+ puts( 1, "\n" )
+end for
diff --git a/Task/Ackermann-function/Euphoria/ackermann-function-2.eu b/Task/Ackermann-function/Euphoria/ackermann-function-2.eu
new file mode 100644
index 0000000000..74b9aed6af
--- /dev/null
+++ b/Task/Ackermann-function/Euphoria/ackermann-function-2.eu
@@ -0,0 +1,12 @@
+function ackermann(integer m, integer n)
+ if m=0 then return n+1
+ elsif m>0 and n=0 then return ackermann(m-1, 1)
+ elsif m>0 and n>0 then return ackermann(m-1, ackermann(m,n-1))
+ else return 0
+ end if
+ return 0
+end function
+
+? ackermann(0, 0)
+? ackermann(3, 4)
+? ackermann(3, 10)
diff --git a/Task/Ackermann-function/Gleam/ackermann-function.gleam b/Task/Ackermann-function/Gleam/ackermann-function.gleam
new file mode 100644
index 0000000000..a7e3dabae4
--- /dev/null
+++ b/Task/Ackermann-function/Gleam/ackermann-function.gleam
@@ -0,0 +1,20 @@
+pub fn ackermann(m: Int, n: Int) -> Int {
+ case m, n {
+ 0, n -> n + 1
+ m, 0 -> ackermann(m - 1, 1)
+ m, n -> ackermann(m - 1, ackermann(m, n - 1))
+ }
+}
+
+pub fn main() {
+ echo ackermann(0, 0)
+ echo ackermann(0, 4)
+ echo ackermann(1, 0)
+ echo ackermann(1, 1)
+ echo ackermann(2, 1)
+ echo ackermann(2, 2)
+ echo ackermann(3, 1)
+ echo ackermann(3, 3)
+ echo ackermann(4, 0)
+ echo ackermann(4, 1)
+}
diff --git a/Task/Ackermann-function/HPPPL/ackermann-function.hpppl b/Task/Ackermann-function/HPPPL/ackermann-function.hpppl
new file mode 100644
index 0000000000..58ff78bae1
--- /dev/null
+++ b/Task/Ackermann-function/HPPPL/ackermann-function.hpppl
@@ -0,0 +1,17 @@
+//subAck1();
+EXPORT Ackermann_function(m,n)
+BEGIN
+PRINT;
+ PRINT("Ackermann("+m+","+n+") = "+subAck1(m,n));
+END;
+
+subAck1(m,n)
+BEGIN
+CASE
+ IF m<0 OR n<0 THEN "m y n deben ser >=0" END;
+ IF m=0 THEN n+1 END;
+ IF m>0 AND n=0 THEN subAck1((m-1),1); END;
+ IF m>0 AND n>0 THEN subAck1((m-1),subAck1(m,(n-1))); END;
+ DEFAULT RETURN PRINT("ERROR");
+END;
+END;
diff --git a/Task/Ackermann-function/Haxe/ackermann-function.hx b/Task/Ackermann-function/Haxe/ackermann-function.hx
new file mode 100644
index 0000000000..e95d735efc
--- /dev/null
+++ b/Task/Ackermann-function/Haxe/ackermann-function.hx
@@ -0,0 +1,20 @@
+class RosettaDemo
+{
+ static public function main()
+ {
+ Sys.print(ackermann(3, 4));
+ }
+
+ static function ackermann(m : Int, n : Int)
+ {
+ if (m == 0)
+ {
+ return n + 1;
+ }
+ else if (n == 0)
+ {
+ return ackermann(m-1, 1);
+ }
+ return ackermann(m-1, ackermann(m, n-1));
+ }
+}
diff --git a/Task/Ackermann-function/Phix/ackermann-function-1.phix b/Task/Ackermann-function/Phix/ackermann-function-1.phix
index a97f6e3ba8..6947767a02 100644
--- a/Task/Ackermann-function/Phix/ackermann-function-1.phix
+++ b/Task/Ackermann-function/Phix/ackermann-function-1.phix
@@ -1,4 +1,4 @@
-(phixonline)-->
+(phixonline)--(notpygments)-->
function ack(integer m, integer n)
if m=0 then
return n+1
diff --git a/Task/Ackermann-function/Phix/ackermann-function-2.phix b/Task/Ackermann-function/Phix/ackermann-function-2.phix
index 6080743529..3c54091afd 100644
--- a/Task/Ackermann-function/Phix/ackermann-function-2.phix
+++ b/Task/Ackermann-function/Phix/ackermann-function-2.phix
@@ -1,4 +1,4 @@
-(phixonline)-->
+(phixonline)--(notpygments)-->
-- demo\rosetta\Ackermann.exw
include mpfr.e
diff --git a/Task/Ackermann-function/PowerShell/ackermann-function-1.ps1 b/Task/Ackermann-function/PowerShell/ackermann-function-1.ps1
new file mode 100644
index 0000000000..f9d21e4e7f
--- /dev/null
+++ b/Task/Ackermann-function/PowerShell/ackermann-function-1.ps1
@@ -0,0 +1,11 @@
+function ackermann ([long] $m, [long] $n) {
+ if ($m -eq 0) {
+ return $n + 1
+ }
+
+ if ($n -eq 0) {
+ return (ackermann ($m - 1) 1)
+ }
+
+ return (ackermann ($m - 1) (ackermann $m ($n - 1)))
+}
diff --git a/Task/Ackermann-function/PowerShell/ackermann-function-2.ps1 b/Task/Ackermann-function/PowerShell/ackermann-function-2.ps1
new file mode 100644
index 0000000000..a8ef2f8842
--- /dev/null
+++ b/Task/Ackermann-function/PowerShell/ackermann-function-2.ps1
@@ -0,0 +1,6 @@
+foreach ($m in 0..3) {
+ foreach ($n in 0..6) {
+ Write-Host -NoNewline ("{0,5}" -f (ackermann $m $n))
+ }
+ Write-Host
+}
diff --git a/Task/Ackermann-function/PowerShell/ackermann-function-3.ps1 b/Task/Ackermann-function/PowerShell/ackermann-function-3.ps1
new file mode 100644
index 0000000000..cb92013c7d
--- /dev/null
+++ b/Task/Ackermann-function/PowerShell/ackermann-function-3.ps1
@@ -0,0 +1,14 @@
+function Get-Ackermann ([int64]$m, [int64]$n)
+{
+ if ($m -eq 0)
+ {
+ return $n + 1
+ }
+
+ if ($n -eq 0)
+ {
+ return Get-Ackermann ($m - 1) 1
+ }
+
+ return (Get-Ackermann ($m - 1) (Get-Ackermann $m ($n - 1)))
+}
diff --git a/Task/Ackermann-function/PowerShell/ackermann-function-4.ps1 b/Task/Ackermann-function/PowerShell/ackermann-function-4.ps1
new file mode 100644
index 0000000000..c43df1d52a
--- /dev/null
+++ b/Task/Ackermann-function/PowerShell/ackermann-function-4.ps1
@@ -0,0 +1,3 @@
+$ackermann = 0..3 | ForEach-Object {$m = $_; 0..6 | ForEach-Object {Get-Ackermann $m $_}}
+
+$ackermann | Format-Wide {"{0,3}" -f $_} -Column 7 -Force
diff --git a/Task/Ackermann-function/REXX/ackermann-function.rexx b/Task/Ackermann-function/REXX/ackermann-function.rexx
new file mode 100644
index 0000000000..5ef80aa39d
--- /dev/null
+++ b/Task/Ackermann-function/REXX/ackermann-function.rexx
@@ -0,0 +1,83 @@
+-- 27 Oct 2025
+include Setting
+numeric digits 310000
+
+say 'ACKERMANN FUNCTION'
+say version
+say
+call Ackermann1
+call Ackermann2
+exit
+
+Ackermann1:
+procedure expose glob.
+say 'Using recursion...'
+do i=0 to 3
+ do j=0 to 10
+ say 'Ackermann('i','j')' '=' Acker1(i,j) Elaps('r')'s'
+ end
+end
+say
+return
+
+Acker1:
+procedure
+arg xx,yy
+select
+ when xx = 0 then
+ return yy+1
+ when yy = 0 then
+ return Acker1(xx-1,1)
+ otherwise
+ return Acker1(xx-1,Acker1(xx,yy-1))
+end
+
+Ackermann2:
+procedure expose glob.
+say 'Using closed formulas...'
+do i=0 to 3
+ do j=0 to 10
+ say 'Ackermann('i','j')' '=' Acker2(i,j) Elaps('r')'s'
+ end
+end
+say 'Ackermann(3,100) =' Acker2(3,100) Elaps('r')'s'
+say 'Ackermann(3,1000) has' Length(Acker2(3,1000)) 'digits' Elaps('r')'s'
+say 'Ackermann(3,10000) has' Length(Acker2(3,10000)) 'digits' Elaps('r')'s'
+say 'Ackermann(3,100000) has' Length(Acker2(3,100000)) 'digits' Elaps('r')'s'
+say 'Ackermann(3,1000000) has' Length(Acker2(3,1000000)) 'digits' Elaps('r')'s'
+say 'Ackermann(4,0) =' Acker2(4,0) Elaps('r')'s'
+say 'Ackermann(4,1) =' Acker2(4,1) Elaps('r')'s'
+say 'Ackermann(4,2) has' Length(Acker2(4,2)) 'digits' Elaps('r')'s'
+return
+
+Acker2:
+procedure
+arg xx,yy
+select
+ when xx=0 then
+ rr=yy+1
+ when xx=1 then
+ rr=yy+2
+ when xx=2 then
+ rr=yy+yy+3
+ when xx=3 then
+ rr=2**(yy+3)-3
+ when xx=4 then
+ select
+ when yy=0 then
+ rr=2**(2**2)-3
+ when yy=1 then
+ rr=2**(2**(2**2))-3
+ when yy=2 then
+ rr=2**(2**(2**(2**2)))-3
+ otherwise
+ rr=0
+ end
+ otherwise
+ rr=0
+end
+return rr
+
+include Abend
+-- Elaps
+include Timer
diff --git a/Task/Ackermann-function/ReScript/ackermann-function.res b/Task/Ackermann-function/ReScript/ackermann-function.res
new file mode 100644
index 0000000000..edb6660918
--- /dev/null
+++ b/Task/Ackermann-function/ReScript/ackermann-function.res
@@ -0,0 +1,15 @@
+let _m = Sys.argv[2]
+let _n = Sys.argv[3]
+
+let m = int_of_string(_m)
+let n = int_of_string(_n)
+
+let rec a = (m, n) =>
+ switch (m, n) {
+ | (0, n) => (n+1)
+ | (m, 0) => a(m-1, 1)
+ | (m, n) => a(m-1, a(m, n-1))
+ }
+
+Js.log("ackermann(" ++ _m ++ ", " ++ _n ++ ") = "
+ ++ string_of_int(a(m, n)))
diff --git a/Task/Ackermann-function/Rebol/ackermann-function-1.rebol b/Task/Ackermann-function/Rebol/ackermann-function-1.rebol
new file mode 100644
index 0000000000..52928c349e
--- /dev/null
+++ b/Task/Ackermann-function/Rebol/ackermann-function-1.rebol
@@ -0,0 +1,7 @@
+ackermann: func [m n] [
+ case [
+ m = 0 [n + 1]
+ n = 0 [ackermann m - 1 1]
+ true [ackermann m - 1 ackermann m n - 1]
+ ]
+]
diff --git a/Task/Ackermann-function/Rebol/ackermann-function-2.rebol b/Task/Ackermann-function/Rebol/ackermann-function-2.rebol
new file mode 100644
index 0000000000..c6e294cb60
--- /dev/null
+++ b/Task/Ackermann-function/Rebol/ackermann-function-2.rebol
@@ -0,0 +1,16 @@
+ackermann: func [
+ m [integer!]
+ n [integer!]
+] [
+ ;; Small-m closed forms
+ case [
+ m = 0 [n + 1]
+ m = 1 [n + 2]
+ m = 2 [(2 * n) + 3]
+ m = 3 [
+ ;; 2^(n+3) - 3
+ (to integer! power 2 (n + 3)) - 3
+ ]
+ ;; m >= 4 causes stack overflow
+ ]
+]
diff --git a/Task/Ackermann-function/Rocq/ackermann-function-1.rocq b/Task/Ackermann-function/Rocq/ackermann-function-1.rocq
new file mode 100644
index 0000000000..61c12cc988
--- /dev/null
+++ b/Task/Ackermann-function/Rocq/ackermann-function-1.rocq
@@ -0,0 +1,18 @@
+Fixpoint ack (m : nat) : nat -> nat :=
+ fix ack_m (n : nat) : nat :=
+ match m with
+ | 0 => S n
+ | S pm =>
+ match n with
+ | 0 => ack pm 1
+ | S pn => ack pm (ack_m pn)
+ end
+ end.
+
+
+(*
+ Example:
+ A(3, 2) = 29
+*)
+
+Eval compute in ack 3 2.
diff --git a/Task/Ackermann-function/Rocq/ackermann-function-2.rocq b/Task/Ackermann-function/Rocq/ackermann-function-2.rocq
new file mode 100644
index 0000000000..bf18b5faa4
--- /dev/null
+++ b/Task/Ackermann-function/Rocq/ackermann-function-2.rocq
@@ -0,0 +1,13 @@
+Require Import Utf8.
+
+Section FOLD.
+ Context {A : Type} (f : A → A) (a : A).
+ Fixpoint fold (n : nat) : A :=
+ match n with
+ | O => a
+ | S k => f (fold k)
+ end.
+End FOLD.
+
+Definition ackermann : nat → nat → nat :=
+ fold (λ g, fold g (g (S O))) S.
diff --git a/Task/Ackermann-function/Uiua/ackermann-function.uiua b/Task/Ackermann-function/Uiua/ackermann-function.uiua
new file mode 100644
index 0000000000..cebcb838cb
--- /dev/null
+++ b/Task/Ackermann-function/Uiua/ackermann-function.uiua
@@ -0,0 +1,7 @@
+A ←|2.1 (
+ ◡(×+1>0:>0)
+ sw(+1pop|A-1:1pop:
+ |A-1:off(A:-1:))
+)
+
+A 1 1
diff --git a/Task/Ackermann-function/VBScript/ackermann-function-1.vbs b/Task/Ackermann-function/VBScript/ackermann-function-1.vbs
new file mode 100644
index 0000000000..a9a32ec1ee
--- /dev/null
+++ b/Task/Ackermann-function/VBScript/ackermann-function-1.vbs
@@ -0,0 +1,20 @@
+option explicit
+'~ dim depth
+function ack(m, n)
+ '~ wscript.stdout.write depth & " "
+ if m = 0 then
+ '~ depth = depth + 1
+ ack = n + 1
+ '~ depth = depth - 1
+ elseif m > 0 and n = 0 then
+ '~ depth = depth + 1
+ ack = ack(m - 1, 1)
+ '~ depth = depth - 1
+ '~ elseif m > 0 and n > 0 then
+ else
+ '~ depth = depth + 1
+ ack = ack(m - 1, ack(m, n - 1))
+ '~ depth = depth - 1
+ end if
+
+end function
diff --git a/Task/Ackermann-function/VBScript/ackermann-function-2.vbs b/Task/Ackermann-function/VBScript/ackermann-function-2.vbs
new file mode 100644
index 0000000000..3d186bb0ed
--- /dev/null
+++ b/Task/Ackermann-function/VBScript/ackermann-function-2.vbs
@@ -0,0 +1,5 @@
+wscript.echo ack( 1, 10 )
+'~ depth = 0
+wscript.echo ack( 2, 1 )
+'~ depth = 0
+wscript.echo ack( 4, 4 )
diff --git a/Task/Active-Directory-Connect/AutoIt/active-directory-connect.au3 b/Task/Active-Directory-Connect/AutoIt/active-directory-connect.au3
new file mode 100644
index 0000000000..21c0bf11dc
--- /dev/null
+++ b/Task/Active-Directory-Connect/AutoIt/active-directory-connect.au3
@@ -0,0 +1,2 @@
+ #include
+_AD_Open()
diff --git a/Task/Active-Directory-Connect/VBScript/active-directory-connect.vbs b/Task/Active-Directory-Connect/VBScript/active-directory-connect.vbs
new file mode 100644
index 0000000000..20a4d6788c
--- /dev/null
+++ b/Task/Active-Directory-Connect/VBScript/active-directory-connect.vbs
@@ -0,0 +1,4 @@
+Set objConn = CreateObject("ADODB.Connection")
+Set objCmd = CreateObject("ADODB.Command")
+objConn.Provider = "ADsDSOObject"
+objConn.Open
diff --git a/Task/Active-Directory-Search-for-a-user/PowerShell/active-directory-search-for-a-user.ps1 b/Task/Active-Directory-Search-for-a-user/PowerShell/active-directory-search-for-a-user.ps1
new file mode 100644
index 0000000000..63a5c8a5cf
--- /dev/null
+++ b/Task/Active-Directory-Search-for-a-user/PowerShell/active-directory-search-for-a-user.ps1
@@ -0,0 +1,7 @@
+Import-Module ActiveDirectory
+
+$searchData = "user name"
+$searchBase = "DC=example,DC=com"
+
+#searches by some of the most common unique identifiers
+get-aduser -Filter((DistinguishedName -eq $searchdata) -or (UserPrincipalName -eq $searchdata) -or (SamAccountName -eq $searchdata)) -SearchBase $searchBase
diff --git a/Task/Active-Directory-Search-for-a-user/VBScript/active-directory-search-for-a-user-1.vbs b/Task/Active-Directory-Search-for-a-user/VBScript/active-directory-search-for-a-user-1.vbs
new file mode 100644
index 0000000000..7dc75eaa5c
--- /dev/null
+++ b/Task/Active-Directory-Search-for-a-user/VBScript/active-directory-search-for-a-user-1.vbs
@@ -0,0 +1,7 @@
+strUsername = "TestUser"
+strQuery = ";"_
+ & "(&(objectclass=*)(samaccountname=" & strUsername & "));distinguishedname;subtree"
+objCmd.ActiveConnection = objConn
+objCmd.Properties("Page Size")=100
+objCmd.CommandText = strQuery
+Set objRS = objCmd.Execute
diff --git a/Task/Active-Directory-Search-for-a-user/VBScript/active-directory-search-for-a-user-2.vbs b/Task/Active-Directory-Search-for-a-user/VBScript/active-directory-search-for-a-user-2.vbs
new file mode 100644
index 0000000000..8a3b362d41
--- /dev/null
+++ b/Task/Active-Directory-Search-for-a-user/VBScript/active-directory-search-for-a-user-2.vbs
@@ -0,0 +1,3 @@
+If objRS.RecordCount = 1 Then
+ WScript.Echo objRS.Fields("DistinguishedName")
+End If
diff --git a/Task/Active-Directory-Search-for-a-user/VBScript/active-directory-search-for-a-user-3.vbs b/Task/Active-Directory-Search-for-a-user/VBScript/active-directory-search-for-a-user-3.vbs
new file mode 100644
index 0000000000..6619fc8fa9
--- /dev/null
+++ b/Task/Active-Directory-Search-for-a-user/VBScript/active-directory-search-for-a-user-3.vbs
@@ -0,0 +1,5 @@
+If objRS.RecordCount > 0 Then
+ For Each objUser in ObjRS
+ WScript.Echo objRS.Fields("DistinguishedName")
+ Next
+End If
diff --git a/Task/Active-object/Ada/active-object.adb b/Task/Active-object/Ada/active-object.adb
new file mode 100644
index 0000000000..c8410cb4d4
--- /dev/null
+++ b/Task/Active-object/Ada/active-object.adb
@@ -0,0 +1,65 @@
+with Ada.Calendar; use Ada.Calendar;
+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 Test_Integrator is
+ type Func is access function (T : Time) return Float;
+
+ function Zero (T : Time) return Float is
+ begin
+ return 0.0;
+ end Zero;
+
+ Epoch : constant Time := Clock;
+
+ function Sine (T : Time) return Float is
+ begin
+ return Sin (Pi * Float (T - Epoch));
+ end Sine;
+
+ task type Integrator is
+ entry Input (Value : Func);
+ entry Output (Value : out Float);
+ entry Shut_Down;
+ end Integrator;
+
+ task body Integrator is
+ K : Func := Zero'Access;
+ S : Float := 0.0;
+ F0 : Float := 0.0;
+ F1 : Float;
+ T0 : Time := Clock;
+ T1 : Time;
+ begin
+ loop
+ select
+ accept Input (Value : Func) do
+ K := Value;
+ end Input;
+ or accept Output (Value : out Float) do
+ Value := S;
+ end Output;
+ or accept Shut_Down;
+ exit;
+ else
+ T1 := Clock;
+ F1 := K (T1);
+ S := S + 0.5 * (F1 + F0) * Float (T1 - T0);
+ T0 := T1;
+ F0 := F1;
+ end select;
+ end loop;
+ end Integrator;
+
+ I : Integrator;
+ S : Float;
+begin
+ I.Input (Sine'Access);
+ delay 2.0;
+ I.Input (Zero'Access);
+ delay 0.5;
+ I.Output (S);
+ Put_Line ("Integrated" & Float'Image (S) & "s");
+ I.Shut_Down;
+end Test_Integrator;
diff --git a/Task/Add-a-variable-to-a-class-instance-at-runtime/Ada/add-a-variable-to-a-class-instance-at-runtime.adb b/Task/Add-a-variable-to-a-class-instance-at-runtime/Ada/add-a-variable-to-a-class-instance-at-runtime.adb
new file mode 100644
index 0000000000..599852f288
--- /dev/null
+++ b/Task/Add-a-variable-to-a-class-instance-at-runtime/Ada/add-a-variable-to-a-class-instance-at-runtime.adb
@@ -0,0 +1,40 @@
+with Ada.Text_IO; use Ada.Text_IO;
+
+procedure Dynamic is
+ package Abstract_Class is
+ type Class is limited interface;
+ function Boo (X : Class) return String is abstract;
+ end Abstract_Class;
+ use Abstract_Class;
+
+ package Base_Class is
+ type Base is new Class with null record;
+ overriding function Boo (X : Base) return String;
+ end Base_Class;
+
+ package body Base_Class is
+ function Boo (X : Base) return String is
+ begin
+ return "I am Class";
+ end Boo;
+ end Base_Class;
+ use Base_Class;
+
+ E : aliased Base; -- An instance of Base
+
+begin
+ -- Gone run-time
+ declare
+ type Monkey_Patch (Root : access Base) is new Class with record
+ Foo : Integer := 1;
+ end record;
+ overriding function Boo (X : Monkey_Patch) return String;
+ function Boo (X : Monkey_Patch) return String is
+ begin -- Delegation to the base
+ return X.Root.Boo;
+ end Boo;
+ EE : Monkey_Patch (E'Access); -- Extend E
+ begin
+ Put_Line (EE.Boo & " with" & Integer'Image (EE.Foo));
+ end;
+end Dynamic;
diff --git a/Task/Add-a-variable-to-a-class-instance-at-runtime/Crystal/add-a-variable-to-a-class-instance-at-runtime.cr b/Task/Add-a-variable-to-a-class-instance-at-runtime/Crystal/add-a-variable-to-a-class-instance-at-runtime.cr
new file mode 100644
index 0000000000..9d091d3e04
--- /dev/null
+++ b/Task/Add-a-variable-to-a-class-instance-at-runtime/Crystal/add-a-variable-to-a-class-instance-at-runtime.cr
@@ -0,0 +1,25 @@
+class SuperDynamic
+ @vars = {} of String => String | Int32
+
+ def set_vars (@vars)
+ end
+
+ macro method_missing (call)
+ {% name = call.name %}
+ {% if name.ends_with? "=" %}
+ {% name = name.gsub(/=$/, "") %}
+ raise "unknown var" unless @vars.has_key? {{name.id.stringify}}
+ @vars[{{name.id.stringify}}] = {{call.args[0].id}}
+ {% else %}
+ @vars[{{name.id.stringify}}]
+ {% end %}
+ end
+end
+
+sd = SuperDynamic.new
+
+sd.set_vars({ "a" => 1, "b" => "2" })
+
+p! sd.a
+sd.a = 99
+p! sd.a
diff --git a/Task/Add-a-variable-to-a-class-instance-at-runtime/Pluto/add-a-variable-to-a-class-instance-at-runtime.pluto b/Task/Add-a-variable-to-a-class-instance-at-runtime/Pluto/add-a-variable-to-a-class-instance-at-runtime.pluto
new file mode 100644
index 0000000000..40869ae8f9
--- /dev/null
+++ b/Task/Add-a-variable-to-a-class-instance-at-runtime/Pluto/add-a-variable-to-a-class-instance-at-runtime.pluto
@@ -0,0 +1,5 @@
+class myclass end
+
+local mc = new myclass()
+mc.somevar = 21
+print(mc.somevar * 2)
diff --git a/Task/Add-a-variable-to-a-class-instance-at-runtime/PowerShell/add-a-variable-to-a-class-instance-at-runtime.ps1 b/Task/Add-a-variable-to-a-class-instance-at-runtime/PowerShell/add-a-variable-to-a-class-instance-at-runtime.ps1
new file mode 100644
index 0000000000..0e1f1589a8
--- /dev/null
+++ b/Task/Add-a-variable-to-a-class-instance-at-runtime/PowerShell/add-a-variable-to-a-class-instance-at-runtime.ps1
@@ -0,0 +1,5 @@
+$x = 42 `
+ | Add-Member -PassThru `
+ NoteProperty `
+ Title `
+ "The answer to the question about life, the universe and everything"
diff --git a/Task/Add-a-variable-to-a-class-instance-at-runtime/Rebol/add-a-variable-to-a-class-instance-at-runtime-1.rebol b/Task/Add-a-variable-to-a-class-instance-at-runtime/Rebol/add-a-variable-to-a-class-instance-at-runtime-1.rebol
new file mode 100644
index 0000000000..f78f102672
--- /dev/null
+++ b/Task/Add-a-variable-to-a-class-instance-at-runtime/Rebol/add-a-variable-to-a-class-instance-at-runtime-1.rebol
@@ -0,0 +1,48 @@
+Rebol [
+ Title: "Add Variables to Class at Runtime"
+ URL: http://rosettacode.org/wiki/Adding_variables_to_a_class_instance_at_runtime
+]
+
+; As I understand it, a REBOL object can only ever have whatever
+; properties it was born with. However, this is somewhat offset by the
+; fact that every instance can serve as a prototype for a new object
+; that also has the new parameter you want to add.
+
+; Here I create an empty instance of the base object (x), then add the
+; new instance variable while creating a new object prototyped from
+; x. I assign the new object to x, et voila', a dynamically added
+; variable.
+
+x: make object! [] ; Empty object.
+
+x: make x [
+ newvar: "forty-two" ; New property.
+]
+
+print "Empty object modifed with 'newvar' property:"
+probe x
+
+; A slightly more interesting example:
+
+starfighter: make object! [
+ model: "unknown"
+ pilot: none
+]
+x-wing: make starfighter [
+ model: "Incom T-65 X-wing"
+]
+
+squadron: reduce [
+ make x-wing [pilot: "Luke Skywalker"]
+ make x-wing [pilot: "Wedge Antilles"]
+ make starfighter [
+ model: "Slayn & Korpil B-wing"
+ pilot: "General Salm"
+ ]
+]
+
+; Adding new property here.
+squadron/1: make squadron/1 [deathstar-removal-expert: yes]
+
+print [crlf "Fighter squadron:"]
+foreach pilot squadron [probe pilot]
diff --git a/Task/Add-a-variable-to-a-class-instance-at-runtime/Rebol/add-a-variable-to-a-class-instance-at-runtime-2.rebol b/Task/Add-a-variable-to-a-class-instance-at-runtime/Rebol/add-a-variable-to-a-class-instance-at-runtime-2.rebol
new file mode 100644
index 0000000000..47e1beaf8d
--- /dev/null
+++ b/Task/Add-a-variable-to-a-class-instance-at-runtime/Rebol/add-a-variable-to-a-class-instance-at-runtime-2.rebol
@@ -0,0 +1,5 @@
+>> o: object [a: 1] put o 'b 2 o
+== make object! [
+ a: 1
+ b: 2
+]
diff --git a/Task/Add-a-variable-to-a-class-instance-at-runtime/V-(Vlang)/add-a-variable-to-a-class-instance-at-runtime.v b/Task/Add-a-variable-to-a-class-instance-at-runtime/V-(Vlang)/add-a-variable-to-a-class-instance-at-runtime.v
new file mode 100644
index 0000000000..7ef1ee8833
--- /dev/null
+++ b/Task/Add-a-variable-to-a-class-instance-at-runtime/V-(Vlang)/add-a-variable-to-a-class-instance-at-runtime.v
@@ -0,0 +1,35 @@
+import os
+import strconv
+
+struct Obj {
+ mut:
+ var map[string]string
+}
+
+fn main() {
+ mut obj := Obj{}
+ mut nir, mut ir := 0, 1
+ mut name, mut val := "", ""
+ for nir < 1 || nir > 3 {
+ nir = strconv.atoi(os.input("How many variables to create (max 3): ")) or
+ {println("Invalid input!") continue}
+ }
+ for ir <= nir {
+ println("Enter the variable names and their values, below:")
+ println("Variable ${ir}")
+ name = os.input_opt(" Name: ") or {println("Invalid input!") exit(1)}
+ for {
+ val = os.input_opt(" Value: ") or {println("Invalid input!") exit(2)}
+ break
+ }
+ obj.var[name] = val
+ ir++
+ }
+ println("\n" + "Enter q to quit")
+ for {
+ name = os.input_opt("Which variable (field) name to inspect : ") or {continue}
+ if name.to_lower() == "q" {break}
+ if name !in obj.var {println("There's no variable (field) of that name, try again")}
+ else {println("It's value is: '${obj.var[name]}'")}
+ }
+}
diff --git a/Task/Additive-primes/Ada/additive-primes.adb b/Task/Additive-primes/Ada/additive-primes.adb
new file mode 100644
index 0000000000..800f5d1f23
--- /dev/null
+++ b/Task/Additive-primes/Ada/additive-primes.adb
@@ -0,0 +1,58 @@
+with Ada.Text_Io;
+
+procedure Additive_Primes is
+
+ Last : constant := 499;
+ Columns : constant := 12;
+
+ type Prime_List is array (2 .. Last) of Boolean;
+
+ function Get_Primes return Prime_List is
+ Prime : Prime_List := (others => True);
+ begin
+ for P in Prime'Range loop
+ if Prime (P) then
+ for N in 2 .. Positive'Last loop
+ exit when N * P not in Prime'Range;
+ Prime (N * P) := False;
+ end loop;
+ end if;
+ end loop;
+ return Prime;
+ end Get_Primes;
+
+ function Sum_Of (N : Natural) return Natural is
+ Image : constant String := Natural'Image (N);
+ Sum : Natural := 0;
+ begin
+ for Char of Image loop
+ Sum := Sum + (if Char in '0' .. '9'
+ then Natural'Value ("" & Char)
+ else 0);
+ end loop;
+ return Sum;
+ end Sum_Of;
+
+ package Natural_Io is new Ada.Text_Io.Integer_Io (Natural);
+ use Ada.Text_Io, Natural_Io;
+
+ Prime : constant Prime_List := Get_Primes;
+ Count : Natural := 0;
+begin
+ Put_Line ("Additive primes <500:");
+ for N in Prime'Range loop
+ if Prime (N) and then Prime (Sum_Of (N)) then
+ Count := Count + 1;
+ Put (N, Width => 5);
+ if Count mod Columns = 0 then
+ New_Line;
+ end if;
+ end if;
+ end loop;
+ New_Line;
+
+ Put ("There are ");
+ Put (Count, Width => 2);
+ Put (" additive primes.");
+ New_Line;
+end Additive_Primes;
diff --git a/Task/Additive-primes/COBOL/additive-primes.cob b/Task/Additive-primes/COBOL/additive-primes.cob
new file mode 100644
index 0000000000..bcdc97c71e
--- /dev/null
+++ b/Task/Additive-primes/COBOL/additive-primes.cob
@@ -0,0 +1,73 @@
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. ADDITIVE-PRIMES.
+
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 VARIABLES.
+ 03 MAXIMUM PIC 999.
+ 03 AMOUNT PIC 999.
+ 03 CANDIDATE PIC 999.
+ 03 DIGIT PIC 9 OCCURS 3 TIMES,
+ REDEFINES CANDIDATE.
+ 03 DIGITSUM PIC 99.
+
+ 01 PRIME-DATA.
+ 03 COMPOSITE-FLAG PIC X OCCURS 500 TIMES.
+ 88 PRIME VALUE ' '.
+ 03 SIEVE-PRIME PIC 999.
+ 03 SIEVE-COMP-START PIC 999.
+ 03 SIEVE-COMP PIC 999.
+ 03 SIEVE-MAX PIC 999.
+
+ 01 OUT-FMT.
+ 03 NUM-FMT PIC ZZZ9.
+ 03 OUT-LINE PIC X(40).
+ 03 OUT-PTR PIC 99.
+
+ PROCEDURE DIVISION.
+ BEGIN.
+ MOVE 500 TO MAXIMUM.
+ MOVE 1 TO OUT-PTR.
+ PERFORM SIEVE.
+ MOVE ZERO TO AMOUNT.
+ PERFORM TEST-NUMBER
+ VARYING CANDIDATE FROM 2 BY 1
+ UNTIL CANDIDATE IS GREATER THAN MAXIMUM.
+ DISPLAY OUT-LINE.
+ DISPLAY SPACES.
+ MOVE AMOUNT TO NUM-FMT.
+ DISPLAY 'Amount of additive primes found: ' NUM-FMT.
+ STOP RUN.
+
+ TEST-NUMBER.
+ ADD DIGIT(1), DIGIT(2), DIGIT(3) GIVING DIGITSUM.
+ IF PRIME(CANDIDATE) AND PRIME(DIGITSUM),
+ ADD 1 TO AMOUNT,
+ PERFORM WRITE-NUMBER.
+
+ WRITE-NUMBER.
+ MOVE CANDIDATE TO NUM-FMT.
+ STRING NUM-FMT DELIMITED BY SIZE INTO OUT-LINE
+ WITH POINTER OUT-PTR.
+ IF OUT-PTR IS GREATER THAN 40,
+ DISPLAY OUT-LINE,
+ MOVE SPACES TO OUT-LINE,
+ MOVE 1 TO OUT-PTR.
+
+ SIEVE.
+ MOVE SPACES TO PRIME-DATA.
+ DIVIDE MAXIMUM BY 2 GIVING SIEVE-MAX.
+ PERFORM SIEVE-OUTER-LOOP
+ VARYING SIEVE-PRIME FROM 2 BY 1
+ UNTIL SIEVE-PRIME IS GREATER THAN SIEVE-MAX.
+
+ SIEVE-OUTER-LOOP.
+ IF PRIME(SIEVE-PRIME),
+ MULTIPLY SIEVE-PRIME BY 2 GIVING SIEVE-COMP-START,
+ PERFORM SIEVE-INNER-LOOP
+ VARYING SIEVE-COMP
+ FROM SIEVE-COMP-START BY SIEVE-PRIME
+ UNTIL SIEVE-COMP IS GREATER THAN MAXIMUM.
+
+ SIEVE-INNER-LOOP.
+ MOVE 'X' TO COMPOSITE-FLAG(SIEVE-COMP).
diff --git a/Task/Additive-primes/Icon/additive-primes.icon b/Task/Additive-primes/Icon/additive-primes.icon
new file mode 100644
index 0000000000..513992b151
--- /dev/null
+++ b/Task/Additive-primes/Icon/additive-primes.icon
@@ -0,0 +1,13 @@
+link factors
+
+procedure main(A)
+ limit := \A[1] | 500
+ every p := prime() do
+ if p < 500 then writes(" ",additive(p)) else break
+ write()
+end
+
+procedure additive(a)
+ a ? (sum := 0, while sum +:= move(1))
+ return (isprime(sum),a)
+end
diff --git a/Task/Additive-primes/Langur/additive-primes.langur b/Task/Additive-primes/Langur/additive-primes.langur
index d6d80fd05f..8fe40c3325 100644
--- a/Task/Additive-primes/Langur/additive-primes.langur
+++ b/Task/Additive-primes/Langur/additive-primes.langur
@@ -1,9 +1,9 @@
-val isPrime = fn(i) {
- i == 2 or i > 2 and
- not any(series(2 .. i ^/ 2, asconly=true), by=fn x:i div x)
+val isPrime = fn(i number) {
+ i == 2 or i > 2 and
+ not any(series(2 .. i ^/ 2, asconly=true), by=fn(x) { i div x })
}
-val sumDigits = fn i: fold(s2n(string(i)), by=fn{+})
+val sumDigits = fn(i) { fold(s2n(string(i)), by=fn{+}) }
writeln "Additive primes less than 500:"
diff --git a/Task/Additive-primes/Pluto/additive-primes.pluto b/Task/Additive-primes/Pluto/additive-primes.pluto
new file mode 100644
index 0000000000..dfc881f585
--- /dev/null
+++ b/Task/Additive-primes/Pluto/additive-primes.pluto
@@ -0,0 +1,14 @@
+local int = require "int"
+local fmt = require "fmt"
+
+print("Additive primes less than 500:")
+local primes = int.primes(499)
+local count = 0
+for primes as p do
+ if int.isprime(int.digstat(p)[2]) do
+ count += 1
+ fmt.write("%3d ", p)
+ if count % 10 == 0 then print() end
+ end
+end
+print($"\n\n{count} additive primes found.")
diff --git a/Task/Additive-primes/Rebol/additive-primes.rebol b/Task/Additive-primes/Rebol/additive-primes.rebol
new file mode 100644
index 0000000000..eb5759c7c4
--- /dev/null
+++ b/Task/Additive-primes/Rebol/additive-primes.rebol
@@ -0,0 +1,42 @@
+Rebol [
+ title: "Rosetta code: Additive primes"
+ file: %Additive_primes.r3
+ url: https://rosettacode.org/wiki/Additive_primes
+ note: "Based on Red language solution"
+]
+primes: function [n [integer!]][
+ ;; See: https://rosettacode.org/wiki/Sieve_of_Eratosthenes#Rebol
+ poke prim: make bitset! n 1 true
+ r: 2 while [r * r <= n][repeat q n / r - 1 [poke prim q + 1 * r true]
+ until [not pick prim r: r + 1]]
+ collect [repeat i n [unless prim/:i [keep i]]]
+]
+;; Compute the digit sum (cross-sum) of an integer n
+cross-sum: function [n][
+ out: 0 ;; accumulator for sum of digits
+ foreach m form n [ ;; iterate over the characters of n's string form
+ out: out - 48 + m ;; convert char to integer, add to out
+ ]
+ out
+]
+;; Return all additive primes <= n:
+;; A prime p is "additive" if its digit-sum is also prime.
+additive-primes: function [n][
+ collect [
+ foreach p ps: primes n [ ;; generate primes up to n and iterate over them
+ if find ps cross-sum p [ ;; check if digit-sum of p is itself in the prime set
+ keep p ;; keep p if digit-sum is prime
+ ]
+ ]
+ ]
+]
+
+;; Generate additive primes up to 500
+result: additive-primes 500
+;; Format nicely by rows of 10 (with newlines)
+print [length? result "additive primes < 500:"]
+forall result [
+ prin pad result/1 -4
+ if zero? ((index? result) % 10) [print ""]
+]
+print ""
diff --git a/Task/Additive-primes/Uiua/additive-primes.uiua b/Task/Additive-primes/Uiua/additive-primes-1.uiua
similarity index 100%
rename from Task/Additive-primes/Uiua/additive-primes.uiua
rename to Task/Additive-primes/Uiua/additive-primes-1.uiua
diff --git a/Task/Additive-primes/Uiua/additive-primes-2.uiua b/Task/Additive-primes/Uiua/additive-primes-2.uiua
new file mode 100644
index 0000000000..447a6cbce2
--- /dev/null
+++ b/Task/Additive-primes/Uiua/additive-primes-2.uiua
@@ -0,0 +1,2 @@
+Prime ← =₁⧻°/×
+⊸⧻▽⊸≡(×Prime/+⊥₁₀⟜Prime) ↘2⇡500
diff --git a/Task/Additive-primes/Uiua/additive-primes-3.uiua b/Task/Additive-primes/Uiua/additive-primes-3.uiua
new file mode 100644
index 0000000000..c5f88cba42
--- /dev/null
+++ b/Task/Additive-primes/Uiua/additive-primes-3.uiua
@@ -0,0 +1 @@
+Prime ← =₁⧻°/×
diff --git a/Task/Additive-primes/Uiua/additive-primes-4.uiua b/Task/Additive-primes/Uiua/additive-primes-4.uiua
new file mode 100644
index 0000000000..dff5cee7d4
--- /dev/null
+++ b/Task/Additive-primes/Uiua/additive-primes-4.uiua
@@ -0,0 +1 @@
+↘2⇡500
diff --git a/Task/Additive-primes/Uiua/additive-primes-5.uiua b/Task/Additive-primes/Uiua/additive-primes-5.uiua
new file mode 100644
index 0000000000..87bc54f816
--- /dev/null
+++ b/Task/Additive-primes/Uiua/additive-primes-5.uiua
@@ -0,0 +1 @@
+≡(×Prime/+⊥₁₀⟜Prime)
diff --git a/Task/Additive-primes/Uiua/additive-primes-6.uiua b/Task/Additive-primes/Uiua/additive-primes-6.uiua
new file mode 100644
index 0000000000..07cb55f295
--- /dev/null
+++ b/Task/Additive-primes/Uiua/additive-primes-6.uiua
@@ -0,0 +1 @@
+⊸⧻▽⊸
diff --git a/Task/Additive-primes/V-(Vlang)/additive-primes.v b/Task/Additive-primes/V-(Vlang)/additive-primes.v
index 47e8c46bad..49aabd1688 100644
--- a/Task/Additive-primes/V-(Vlang)/additive-primes.v
+++ b/Task/Additive-primes/V-(Vlang)/additive-primes.v
@@ -1,56 +1,34 @@
-fn is_prime(n int) bool {
- if n < 2 {
- return false
- } else if n%2 == 0 {
- return n == 2
- } else if n%3 == 0 {
- return n == 3
- } else {
- mut d := 5
- for d*d <= n {
- if n%d == 0 {
- return false
- }
- d += 2
- if n%d == 0 {
- return false
- }
- d += 4
- }
- return true
- }
-}
+import strconv
-fn sum_digits(nn int) int {
- mut n := nn
- mut sum := 0
- for n > 0 {
- sum += n % 10
- n /= 10
+fn is_prime(n int) bool {
+ if n <= 1 { return false }
+ for i := 2; i * i <= n; i++ {
+ if n % i == 0 { return false }
}
- return sum
+ return true
}
fn main() {
- println("Additive primes less than 500:")
- mut i := 2
- mut count := 0
- for {
- if is_prime(i) && is_prime(sum_digits(i)) {
- count++
- print("${i:3} ")
- if count%10 == 0 {
- println('')
+ mut row := 0
+ limit := 500
+ println("working...")
+ println("Additive primes are:")
+ for n := 1; n <= limit; n++ {
+ if is_prime(n) {
+ strn := n.str()
+ mut num := 0
+ for ch in strn {
+ digit := strconv.atoi(ch.ascii_str()) or { exit(1) }
+ num += digit
+ }
+ if is_prime(num) {
+ row++
+ print("$n ")
+ if row % 10 == 0 { println("") }
}
}
- if i > 2 {
- i += 2
- } else {
- i++
- }
- if i > 499 {
- break
- }
}
- println("\n\n$count additive primes found.")
+ println("")
+ println("found $row additive primes.")
+ println("done...")
}
diff --git a/Task/Address-of-a-variable/Ada/address-of-a-variable-1.adb b/Task/Address-of-a-variable/Ada/address-of-a-variable-1.adb
new file mode 100644
index 0000000000..b4b3d87235
--- /dev/null
+++ b/Task/Address-of-a-variable/Ada/address-of-a-variable-1.adb
@@ -0,0 +1,3 @@
+The_Address : System.Address;
+I : Integer;
+The_Address := I'Address;
diff --git a/Task/Address-of-a-variable/Ada/address-of-a-variable-2.adb b/Task/Address-of-a-variable/Ada/address-of-a-variable-2.adb
new file mode 100644
index 0000000000..665d4b3960
--- /dev/null
+++ b/Task/Address-of-a-variable/Ada/address-of-a-variable-2.adb
@@ -0,0 +1,2 @@
+I : Integer;
+for I'Address use 16#A100#;
diff --git a/Task/Address-of-a-variable/Ada/address-of-a-variable-3.adb b/Task/Address-of-a-variable/Ada/address-of-a-variable-3.adb
new file mode 100644
index 0000000000..f903d446b9
--- /dev/null
+++ b/Task/Address-of-a-variable/Ada/address-of-a-variable-3.adb
@@ -0,0 +1,3 @@
+I : Integer;
+J : Integer;
+for I'Address use J'Address;
diff --git a/Task/Address-of-a-variable/COBOL/address-of-a-variable-1.cob b/Task/Address-of-a-variable/COBOL/address-of-a-variable-1.cob
new file mode 100644
index 0000000000..2bde5d6a6e
--- /dev/null
+++ b/Task/Address-of-a-variable/COBOL/address-of-a-variable-1.cob
@@ -0,0 +1,7 @@
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 ptr USAGE POINTER.
+ 01 var PIC X(64).
+
+ PROCEDURE DIVISION.
+ SET ptr TO ADDRESS OF var.
diff --git a/Task/Address-of-a-variable/COBOL/address-of-a-variable-2.cob b/Task/Address-of-a-variable/COBOL/address-of-a-variable-2.cob
new file mode 100644
index 0000000000..86e2b0b3f2
--- /dev/null
+++ b/Task/Address-of-a-variable/COBOL/address-of-a-variable-2.cob
@@ -0,0 +1,17 @@
+OCOBOL*> Rosetta Code set address example
+ *> tectonics: cobc -x setaddr.cob && ./setaddr
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. setaddr.
+
+ DATA DIVISION.
+ WORKING-STORAGE SECTION.
+ 01 prealloc PIC X(8) VALUE 'somedata'.
+ 01 var PIC X(8) BASED.
+
+ PROCEDURE DIVISION.
+ SET ADDRESS OF var TO ADDRESS OF prealloc
+ DISPLAY var END-DISPLAY
+ *> 'somedata'
+ GOBACK.
+
+ END PROGRAM setaddr.
diff --git a/Task/Address-of-a-variable/Crystal/address-of-a-variable.cr b/Task/Address-of-a-variable/Crystal/address-of-a-variable.cr
new file mode 100644
index 0000000000..4110c86ba4
--- /dev/null
+++ b/Task/Address-of-a-variable/Crystal/address-of-a-variable.cr
@@ -0,0 +1,8 @@
+icr:1> a = 123
+ => 123
+icr:2> p = pointerof(a)
+ => Pointer(Int32)@0x1ed36c20000
+icr:3> p.value = 321
+ => 321
+icr:4> a
+ => 321
diff --git a/Task/Address-of-a-variable/REXX/address-of-a-variable.rexx b/Task/Address-of-a-variable/REXX/address-of-a-variable.rexx
index 4c8e5959ea..274996e7a3 100644
--- a/Task/Address-of-a-variable/REXX/address-of-a-variable.rexx
+++ b/Task/Address-of-a-variable/REXX/address-of-a-variable.rexx
@@ -1,11 +1,12 @@
--- 23 Aug 2025
+-- 21 Feb 2026
include Setting
say 'ADDRESS OF A VARIABLE'
say version
say
call Primes 10
-call DumpVariables
+call Showvars
exit
+-- Primes; Showvars
include Math
diff --git a/Task/Algebraic-data-types/Emacs-Lisp/algebraic-data-types.el b/Task/Algebraic-data-types/Emacs-Lisp/algebraic-data-types.el
new file mode 100644
index 0000000000..8c007bfc1f
--- /dev/null
+++ b/Task/Algebraic-data-types/Emacs-Lisp/algebraic-data-types.el
@@ -0,0 +1,28 @@
+(defun rbt-balance (tree)
+ (pcase tree
+ (`(B (R (R ,a ,x ,b) ,y ,c) ,z ,d) `(R (B ,a ,x ,b) ,y (B ,c ,z ,d)))
+ (`(B (R ,a ,x (R ,b ,y ,c)) ,z ,d) `(R (B ,a ,x ,b) ,y (B ,c ,z ,d)))
+ (`(B ,a ,x (R (R ,b ,y ,c) ,z ,d)) `(R (B ,a ,x ,b) ,y (B ,c ,z ,d)))
+ (`(B ,a ,x (R ,b ,y (R ,c ,z ,d))) `(R (B ,a ,x ,b) ,y (B ,c ,z ,d)))
+ (_ tree)))
+
+(defun rbt-insert- (x s)
+ (pcase s
+ (`nil `(R nil ,x nil))
+ (`(,color ,a ,y ,b) (cond ((< x y)
+ (rbt-balance `(,color ,(rbt-insert- x a) ,y ,b)))
+ ((> x y)
+ (rbt-balance `(,color ,a ,y ,(rbt-insert- x b))))
+ (t
+ s)))
+ (_ (error "Expected tree: %S" s))))
+
+(defun rbt-insert (x s)
+ (pcase (rbt-insert- x s)
+ (`(,_ ,a ,y ,b) `(B ,a ,y ,b))
+ (_ (error "Internal error: %S" s))))
+
+(let ((s nil))
+ (dotimes (i 16)
+ (setq s (rbt-insert (1+ i) s)))
+ (pp s))
diff --git a/Task/Algebraic-data-types/Pluto/algebraic-data-types.pluto b/Task/Algebraic-data-types/Pluto/algebraic-data-types.pluto
new file mode 100644
index 0000000000..4d8388263b
--- /dev/null
+++ b/Task/Algebraic-data-types/Pluto/algebraic-data-types.pluto
@@ -0,0 +1,78 @@
+$define R = "R"
+$define B = "B"
+
+class Tree
+ function ins(_) end -- overridden by child classes
+
+ function insert(x) -- inherited by child classes
+ local t = self:ins(x)
+ if t:type() == "T" then return new T(B, t.le, t.aa, t.ri) end
+ if t:type() == "E" then return new E() end
+ return nil
+ end
+end
+
+class T extends Tree
+ function __construct(
+ public cl, -- color
+ public le, -- Tree
+ public aa, -- integer
+ public ri -- Tree
+ )
+ end
+
+ function type() return "T" end
+
+ function balance()
+ if self.cl != B then return self end
+ local le2 = self.le:type() == "T" ? self.le : nil
+ local lele, leri
+ if le2 then
+ lele = self.le.le:type() == "T" ? self.le.le : nil
+ leri = self.le.ri:type() == "T" ? self.le.ri : nil
+ end
+ local ri2 = self.ri:type() == "T" ? self.ri : nil
+ local rile, riri
+ if ri2 then
+ rile = self.ri.le:type() == "T" ? self.ri.le : nil
+ riri = self.ri.ri.type() == "T" ? self.ri.ri : nil
+ end
+ if le2 and lele and le2.cl == R and lele.cl == R then
+ local t = le2.le
+ return new T(R, new T(B, t.le, t.aa, t.ri), le2.aa, new T(B, le2.ri, self.aa, self.ri))
+ end
+ if le2 and leri and le2.cl == R and leri.cl == R then
+ local t = le2.ri
+ return new T(R, new T(B, le2.le, le2.aa, t.le), t.aa, new T(B, t.ri, self.aa, self.ri))
+ end
+ if ri2 and rile and ri2.cl == R and rile.cl == R then
+ local t = ri2.ri
+ return new T(R, new T(B, self.le, self.aa, t.le), t.aa, new T(B, t.ri, ri2.aa, ri2.ri))
+ end
+ if ri2 and riri and ri2.cl == R and riri.cl == R then
+ local t = ri2.ri
+ return new T(R, new T(B, self.le, self.aa, ri2.le), ri2.aa, new T(B, t.le, t.aa, t.ri))
+ end
+ return self
+ end
+
+ function ins(x)
+ if x < self.aa then return new T(self.cl, self.le:ins(x), self.aa, self.ri):balance() end
+ if x > self.aa then return new T(self.cl, self.le, self.aa, self.ri:ins(x)):balance() end
+ return self
+ end
+
+ function __tostring() return $"T({self.cl}, {self.le}, {self.aa}, {self.ri})" end
+end
+
+class E extends Tree
+ function ins(x) return new T(R, new E(), x, new E()) end
+
+ function type() return "E" end
+
+ function __tostring() return "E" end
+end
+
+local tr = new E()
+for i = 1, 16 do tr = tr:insert(i) end
+print(tr)
diff --git a/Task/Align-columns/Ada/align-columns.adb b/Task/Align-columns/Ada/align-columns.adb
new file mode 100644
index 0000000000..16c857d27a
--- /dev/null
+++ b/Task/Align-columns/Ada/align-columns.adb
@@ -0,0 +1,65 @@
+with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
+with Ada.Text_IO; use Ada.Text_IO;
+with Strings_Edit; use Strings_Edit;
+
+procedure Column_Aligner is
+ Text : constant String :=
+ "Given$a$text$file$of$many$lines,$where$fields$within$a$line$" & NUL &
+ "are$delineated$by$a$single$'dollar'$character,$write$a$program" & NUL &
+ "that$aligns$each$column$of$fields$by$ensuring$that$words$in$each$" & NUL &
+ "column$are$separated$by$at$least$one$space." & NUL &
+ "Further,$allow$for$each$word$in$a$column$to$be$either$left$" & NUL &
+ "justified,$right$justified,$or$center$justified$within$its$column." & NUL;
+ File : File_Type;
+ Width : array (1..1_000) of Natural := (others => 0);
+ Line : String (1..200);
+ Column : Positive := 1;
+ Start : Positive := 1;
+ Pointer : Positive;
+begin
+ Create (File, Out_File, "columned.txt");
+ -- Determining the widths of columns
+ for I in Text'Range loop
+ case Text (I) is
+ when '$' | NUL =>
+ Width (Column) := Natural'Max (Width (Column), I - Start + 1);
+ Start := I + 1;
+ if Text (I) = NUL then
+ Column := 1;
+ else
+ Column := Column + 1;
+ end if;
+ when others =>
+ null;
+ end case;
+ end loop;
+ -- Formatting
+ for Align in Alignment loop
+ Column := 1;
+ Start := 1;
+ Pointer := 1;
+ for I in Text'Range loop
+ case Text (I) is
+ when '$' | NUL =>
+ Put -- Formatted output of a word
+ ( Destination => Line,
+ Pointer => Pointer,
+ Value => Text (Start..I - 1),
+ Field => Width (Column),
+ Justify => Align
+ );
+ Start := I + 1;
+ if Text (I) = NUL then
+ Put_Line (File, Line (1..Pointer - 1));
+ Pointer := 1;
+ Column := 1;
+ else
+ Column := Column + 1;
+ end if;
+ when others =>
+ null;
+ end case;
+ end loop;
+ end loop;
+ Close (File);
+end Column_Aligner;
diff --git a/Task/Align-columns/AutoIt/align-columns.au3 b/Task/Align-columns/AutoIt/align-columns.au3
new file mode 100644
index 0000000000..9f63e34736
--- /dev/null
+++ b/Task/Align-columns/AutoIt/align-columns.au3
@@ -0,0 +1,83 @@
+; == If the given text is in an file, it will read with:
+#include
+Global $aRead
+_FileReadToArray($sPath, $aRead) ; == $aRead[0] includes count of lines, every line stored in one item (without linebreak)
+
+; == For example we get the same result with StringSplit()
+Global $sText = _
+"Given$a$text$file$of$many$lines,$where$fields$within$a$line$" & @CRLF & _
+"are$delineated$by$a$single$'dollar'$character,$write$a$program" & @CRLF & _
+"that$aligns$each$column$of$fields$by$ensuring$that$words$in$each$" & @CRLF & _
+"column$are$separated$by$at$least$one$space." & @CRLF & _
+"Further,$allow$for$each$word$in$a$column$to$be$either$left$" & @CRLF & _
+"justified,$right$justified,$or$center$justified$within$its$column." & @CRLF
+
+$aRead = StringSplit($sText, @CRLF, 1)
+
+; == strip leading and trailing "$" and trailing spaces, count remaining "$" to get max column number
+Global $iMaxColumn = 0, $iLines = 0
+For $i = 1 To $aRead[0]
+ If $aRead[$i] = '' Then ContinueLoop ; skip empty lines
+ $iLines += 1
+ $aRead[$i] = StringRegExpReplace(StringRegExpReplace(StringRegExpReplace($aRead[$i], '^\$', ''), '\$$', ''), '\s*$', '')
+ StringReplace($aRead[$i], '$', '$')
+ If @extended +1 > $iMaxColumn Then $iMaxColumn = @extended +1
+Next
+
+; == build array to store all fields and length of every item
+Global $aFields[$iLines][$iMaxColumn +1][2]
+; == and store the max. length of item in columns
+Global $aColLen[$iMaxColumn]
+
+; == fill the array
+Global $aSplitLine
+$iLines = 0
+For $i = 1 To $aRead[0]
+ If $aRead[$i] = '' Then ContinueLoop ; skip empty lines
+ $iMaxColLen = 0
+ $aSplitLine = StringSplit($aRead[$i], '$')
+ For $j = 1 To $aSplitLine[0]
+ $aFields[$iLines][$j-1][0] = $aSplitLine[$j]
+ $aFields[$iLines][$j-1][1] = StringLen($aSplitLine[$j])
+ If $aFields[$iLines][$j-1][1] > $aColLen[$j-1] Then $aColLen[$j-1] = $aFields[$iLines][$j-1][1]
+ Next
+ $iLines += 1
+Next
+
+; == let the user select the alignment for every column
+$sAlign = InputBox('Column alignment', 'There are ' & $iMaxColumn & ' columns.' & @LF & '0 = left 1 = center 2 = right' & @LF & _
+ 'Input alignment for all columns without delimiters.' & @LF & 'Let it empty, to align all left.')
+If $sAlign = '' Then
+ For $i = 1 To $iMaxColumn
+ $sAlign &= '0'
+ Next
+EndIf
+Global $aAlignment = StringSplit($sAlign, '', 2)
+
+; == output all to console
+Global $sLineOut
+For $i = 0 To UBound($aFields) -1
+ $sLineOut = ''
+ For $j = 0 To $iMaxColumn -1
+ If $aFields[$i][$j][0] = '' Then ContinueLoop
+ $sLineOut &= _GetAligned($aFields[$i][$j][0], $aFields[$i][$j][1], $aAlignment[$j], $aColLen[$j])
+ Next
+ ConsoleWrite(StringTrimRight($sLineOut, 1) & @LF)
+Next
+
+Func _GetAligned($_sString, $_iLen, $_iAlign, $_iMaxLen)
+ Local $sSpace = ''
+ For $i = 1 To $_iMaxLen
+ $sSpace &= ' '
+ Next
+ Switch $_iAlign
+ Case 0
+ Return $_sString & StringLeft($sSpace, $_iMaxLen - $_iLen +1)
+ Case 1
+ Local $iLenLeft = Int(($_iMaxLen - $_iLen)/2)
+ Local $iLenRight = $_iMaxLen - $iLenLeft - $_iLen
+ Return StringLeft($sSpace, $iLenLeft) & $_sString & StringLeft($sSpace, $iLenRight) & ' '
+ Case 2
+ Return StringLeft($sSpace, $_iMaxLen - $_iLen) & $_sString & ' '
+ EndSwitch
+EndFunc ;==>_GetAligned
diff --git a/Task/Align-columns/COBOL/align-columns-1.cob b/Task/Align-columns/COBOL/align-columns-1.cob
new file mode 100644
index 0000000000..9228acbc68
--- /dev/null
+++ b/Task/Align-columns/COBOL/align-columns-1.cob
@@ -0,0 +1,83 @@
+ identification division.
+ program-id. AlignColumns.
+
+ data division.
+ working-storage section.
+ *>-> Constants
+ 78 MAX-LINES value 6.
+ 78 MAX-LINE-SIZE value 66.
+ 78 MAX-COLUMNS value 12.
+ 78 MAX-COLUMN-SIZE value 16.
+ *>-> Indexes
+ 01 w-idx pic is 9(2).
+ 01 w-idy pic is 9(2).
+ 01 w-pos pic is 9(3).
+ *>-> Data structures
+ 01 w-lines.
+ 05 w-line pic is x(MAX-LINE-SIZE) occurs MAX-LINES.
+ 01 w-column-sizes.
+ 05 w-column-size pic is 99 occurs MAX-COLUMNS value zeros.
+ 01 w-matrix.
+ 05 filler occurs MAX-LINES.
+ 10 filler occurs MAX-COLUMNS.
+ 15 w-content pic is x(MAX-COLUMN-SIZE).
+ *>-> Output
+ 01 w-line-out pic is x(120).
+ *>-> Data alignment
+ 01 w-alignment pic is x(1).
+ 88 alignment-left value is "L".
+ 88 alignment-center value is "C".
+ 88 alignment-right value is "R".
+
+ procedure division.
+ main.
+ move "Given$a$text$file$of$many$lines,$where$fields$within$a$line$" to w-line(1)
+ move "are$delineated$by$a$single$'dollar'$character,$write$a$program" to w-line(2)
+ move "that$aligns$each$column$of$fields$by$ensuring$that$words$in$each$" to w-line(3)
+ move "column$are$separated$by$at$least$one$space." to w-line(4)
+ move "Further,$allow$for$each$word$in$a$column$to$be$either$left$" to w-line(5)
+ move "justified,$right$justified,$or$center$justified$within$its$column." to w-line(6)
+ perform calculate-size-columns
+ set alignment-left to true
+ perform show-content
+ set alignment-center to true
+ perform show-content
+ set alignment-right to true
+ perform show-content
+ goback
+ .
+ calculate-size-columns.
+ perform
+ varying w-idx from 1 by 1
+ until w-idx > MAX-LINES
+ unstring w-line(w-idx) delimited by "$" into w-content(w-idx, 1), w-content(w-idx, 2),
+ w-content(w-idx, 3), w-content(w-idx, 4), w-content(w-idx, 5), w-content(w-idx, 6),
+ w-content(w-idx, 7), w-content(w-idx, 8), w-content(w-idx, 9), w-content(w-idx, 10),
+ w-content(w-idx, 11), w-content(w-idx, 12),
+ perform
+ varying w-idy from 1 by 1
+ until w-idy > MAX-COLUMNS
+ if function stored-char-length(w-content(w-idx, w-idy)) > w-column-size(w-idy)
+ move function stored-char-length(w-content(w-idx, w-idy)) to w-column-size(w-idy)
+ end-if
+ end-perform
+ end-perform
+ .
+ show-content.
+ move all "-" to w-line-out
+ display w-line-out
+ perform
+ varying w-idx from 1 by 1
+ until w-idx > MAX-LINES
+ move spaces to w-line-out
+ move 1 to w-pos
+ perform
+ varying w-idy from 1 by 1
+ until w-idy > MAX-COLUMNS
+ call "C$JUSTIFY" using w-content(w-idx, w-idy)(1:w-column-size(w-idy)), w-alignment
+ move w-content(w-idx, w-idy) to w-line-out(w-pos:w-column-size(w-idy))
+ compute w-pos = w-pos + w-column-size(w-idy) + 1
+ end-perform
+ display w-line-out
+ end-perform
+ .
diff --git a/Task/Align-columns/COBOL/align-columns-2.cob b/Task/Align-columns/COBOL/align-columns-2.cob
new file mode 100644
index 0000000000..9e71439879
--- /dev/null
+++ b/Task/Align-columns/COBOL/align-columns-2.cob
@@ -0,0 +1,21 @@
+------------------------------------------------------------------------------------------------------------------------
+Given a text file of many lines, where fields within a line
+are delineated by a single 'dollar' character, write a program
+that aligns each column of fields by ensuring that words in each
+column are separated by at least one space.
+Further, allow for each word in a column to be either left
+justified, right justified, or center justified within its column.
+------------------------------------------------------------------------------------------------------------------------
+ Given a text file of many lines, where fields within a line
+ are delineated by a single 'dollar' character, write a program
+ that aligns each column of fields by ensuring that words in each
+ column are separated by at least one space.
+ Further, allow for each word in a column to be either left
+justified, right justified, or center justified within its column.
+------------------------------------------------------------------------------------------------------------------------
+ Given a text file of many lines, where fields within a line
+ are delineated by a single 'dollar' character, write a program
+ that aligns each column of fields by ensuring that words in each
+ column are separated by at least one space.
+ Further, allow for each word in a column to be either left
+justified, right justified, or center justified within its column.
diff --git a/Task/Align-columns/Crystal/align-columns.cr b/Task/Align-columns/Crystal/align-columns.cr
new file mode 100644
index 0000000000..9ce66f84c8
--- /dev/null
+++ b/Task/Align-columns/Crystal/align-columns.cr
@@ -0,0 +1,37 @@
+enum Justification
+ Left
+ Right
+ Center
+end
+
+def align_columns (text, justification = Justification::Left)
+ rows = text.lines.map(&.split('$'))
+
+ field_sizes = (0...rows.max_of(&.size)).map {|idx|
+ rows.max_of {|r| (r[idx]? || "").size }
+ }
+ rows.each do |row|
+ puts row.zip(field_sizes).map {|field, size|
+ case justification
+ in Justification::Left then field.ljust(size)
+ in Justification::Right then field.rjust(size)
+ in Justification::Center then field.center(size)
+ end
+ }.join(' ')
+ end
+end
+
+DSV = <<-EOT
+ Given$a$text$file$of$many$lines,$where$fields$within$a$line$
+ are$delineated$by$a$single$'dollar'$character,$write$a$program
+ that$aligns$each$column$of$fields$by$ensuring$that$words$in$each$
+ column$are$separated$by$at$least$one$space.
+ Further,$allow$for$each$word$in$a$column$to$be$either$left$
+ justified,$right$justified,$or$center$justified$within$its$column.
+ EOT
+
+Justification.values.each do |just|
+ puts "#{just}:"
+ align_columns DSV, just
+ puts
+end
diff --git a/Task/Align-columns/Emacs-Lisp/align-columns.el b/Task/Align-columns/Emacs-Lisp/align-columns.el
new file mode 100644
index 0000000000..3588e6e422
--- /dev/null
+++ b/Task/Align-columns/Emacs-Lisp/align-columns.el
@@ -0,0 +1,134 @@
+(defun prepare-data ()
+ "Process data into list of lists."
+ (let ((all-lines)
+ (processed-line))
+ (dolist (one-line (split-string "Given$a$text$file$of$many$lines,$where$fields$within$a$line$
+are$delineated$by$a$single$'dollar'$character,$write$a$program
+that$aligns$each$column$of$fields$by$ensuring$that$words$in$each$
+column$are$separated$by$at$least$one$space.
+Further,$allow$for$each$word$in$a$column$to$be$either$left$
+justified,$right$justified,$or$center$justified$within$its$column." "[\n\r]" :OMIT-NULLS))
+ (dolist (one-word (split-string one-line "\\$"))
+ (push one-word processed-line))
+ (push (nreverse processed-line) all-lines)
+ (setq processed-line nil))
+ (nreverse all-lines)))
+
+(defun get-column (column-number data)
+ "Get words from COLUMN-NUMBER column in DATA."
+ (let ((column-result))
+ (setq column-number (- column-number 1))
+ (dolist (line data)
+ (if (nth column-number line)
+ (push (nth column-number line) column-result)
+ (push "" column-result)))
+ column-result))
+
+(defun calc-column-width (column-number data)
+ "Calculate padded width for COLUMN-NUMBER in DATA."
+ (let ((column-words (get-column column-number data)))
+ (+ 2 (apply #'max (mapcar #'length column-words)))))
+
+(defun get-last-column (data)
+ "Find the last column in DATA."
+ (apply #'max (mapcar #'length data)))
+
+(defun get-column-widths (data)
+ "Get a list of column widths from DATA."
+ (let ((current-column 1)
+ (last-column (get-last-column data))
+ (column-widths))
+ (while (<= current-column last-column)
+ (push (calc-column-width current-column data) column-widths)
+ (setq current-column (1+ current-column)))
+ (nreverse column-widths)))
+
+(defun get-one-column-width (column-number data)
+ "Get column width of COLUMN-NUMBER from DATA."
+ (let ((column-widths (get-column-widths data)))
+ (nth (- column-number 1) column-widths)))
+
+(defun center-align-one-word (word column-width)
+ "Center align WORD in space of COLUMN-WIDTH."
+ (let* ((word-width (length word))
+ (total-padding (- column-width word-width))
+ (pre-padding-length (/ total-padding 2))
+ (post-padding-length (- column-width (+ pre-padding-length word-width)))
+ (pre-padding (make-string pre-padding-length ? ))
+ (post-padding (make-string post-padding-length ? )))
+ (insert (format "%s%s%s" pre-padding word post-padding))))
+
+(defun center-align-one-line (one-line column-widths)
+ "Center align ONE-LINE using COLUMN-WIDTHS."
+ (let ((word-position 0))
+ (dolist (word one-line)
+ (center-align-one-word word (nth word-position column-widths))
+ (setq word-position (1+ word-position)))))
+
+(defun center-align-lines (data)
+ "Center align columns of words in DATA."
+ (let ((column-widths (get-column-widths data)))
+ (dolist (one-line data)
+ (center-align-one-line one-line column-widths)
+ (insert (format "%s" "\n")))))
+
+(defun left-align-one-word (word column-width)
+ "Left align WORD in space of COLUMN-WIDTH."
+ (let* ((word-width (length word))
+ (total-padding (- column-width word-width))
+ (pre-padding-length 1)
+ (post-padding-length (- column-width (+ pre-padding-length word-width)))
+ (pre-padding (make-string pre-padding-length ? ))
+ (post-padding (make-string post-padding-length ? )))
+ (insert (format "%s%s%s" pre-padding word post-padding))))
+
+(defun left-align-one-line (one-line column-widths)
+ "Left align ONE-LINE using COLUMN-WIDTHS."
+ (let ((word-position 0))
+ (dolist (word one-line)
+ (left-align-one-word word (nth word-position column-widths))
+ (setq word-position (1+ word-position)))))
+
+(defun left-align-lines (data)
+ "Left align columns of words in DATA."
+ (let ((column-widths (get-column-widths data)))
+ (dolist (one-line data)
+ (left-align-one-line one-line column-widths)
+ (insert (format "%s" "\n")))))
+
+(defun right-align-one-word (word column-width)
+ "Right align WORD in space of COLUMN-WIDTH."
+ (let* ((word-width (length word))
+ (total-padding (- column-width word-width))
+ (post-padding-length 1)
+ (pre-padding-length (- column-width (+ post-padding-length word-width)))
+ (pre-padding (make-string pre-padding-length ? ))
+ (post-padding (make-string post-padding-length ? )))
+ (insert (format "%s%s%s" pre-padding word post-padding))))
+
+(defun right-align-one-line (one-line column-widths)
+ "Right align ONE-LINE using COLUMN-WIDTHS."
+ (let ((word-position 0))
+ (dolist (word one-line)
+ (right-align-one-word word (nth word-position column-widths))
+ (setq word-position (1+ word-position)))))
+
+(defun right-align-lines (data)
+ "Right align columns of words in DATA."
+ (let ((column-widths (get-column-widths data)))
+ (dolist (one-line data)
+ (right-align-one-line one-line column-widths)
+ (insert (format "%s" "\n")))))
+
+(defun align-lines (alignment data)
+ "Write DATA with given ALIGNMENT.
+DATA consists of a list of lists. Each internal list conists of a list
+of words."
+ (let ((align-function (pcase alignment
+ ('left 'left-align-lines)
+ ("left" 'left-align-lines)
+ ('center 'center-align-lines)
+ ("center" 'center-align-lines)
+ ('right 'right-align-lines)
+ ("right" 'right-align-lines))))
+ (funcall align-function data)))
diff --git a/Task/Align-columns/Euphoria/align-columns.eu b/Task/Align-columns/Euphoria/align-columns.eu
new file mode 100644
index 0000000000..6e031deaf3
--- /dev/null
+++ b/Task/Align-columns/Euphoria/align-columns.eu
@@ -0,0 +1,61 @@
+constant data = {
+ "Given$a$text$file$of$many$lines,$where$fields$within$a$line$",
+ "are$delineated$by$a$single$'dollar'$character,$write$a$program",
+ "that$aligns$each$column$of$fields$by$ensuring$that$words$in$each$",
+ "column$are$separated$by$at$least$one$space.",
+ "Further,$allow$for$each$word$in$a$column$to$be$either$left$",
+ "justified,$right$justified,$or$center$justified$within$its$column."
+}
+
+function split(sequence s, integer c)
+ sequence out
+ integer first, delim
+ out = {}
+ first = 1
+ while first<=length(s) do
+ delim = find_from(c,s,first)
+ if delim = 0 then
+ delim = length(s)+1
+ end if
+ out = append(out,s[first..delim-1])
+ first = delim + 1
+ end while
+ return out
+end function
+
+function align(sequence s, integer width, integer alignment)
+ integer n
+ n = width - length(s)
+ if n <= 0 then
+ return s
+ elsif alignment < 0 then
+ return s & repeat(' ', n)
+ elsif alignment > 0 then
+ return repeat(' ', n) & s
+ else
+ return repeat(' ', floor(n/2)) & s & repeat(' ', floor(n/2+0.5))
+ end if
+end function
+
+integer maxlen
+sequence lines
+maxlen = 0
+lines = repeat(0,length(data))
+for i = 1 to length(data) do
+ lines[i] = split(data[i],'$')
+ for j = 1 to length(lines[i]) do
+ if length(lines[i][j]) > maxlen then
+ maxlen = length(lines[i][j])
+ end if
+ end for
+end for
+
+for a = -1 to 1 do
+ for i = 1 to length(lines) do
+ for j = 1 to length(lines[i]) do
+ puts(1, align(lines[i][j],maxlen,a) & ' ')
+ end for
+ puts(1,'\n')
+ end for
+ puts(1,'\n')
+end for
diff --git a/Task/Align-columns/PowerShell/align-columns.ps1 b/Task/Align-columns/PowerShell/align-columns.ps1
new file mode 100644
index 0000000000..3cfe07a5d2
--- /dev/null
+++ b/Task/Align-columns/PowerShell/align-columns.ps1
@@ -0,0 +1,22 @@
+$file =
+@'
+Given$a$text$file$of$many$lines,$where$fields$within$a$line$
+are$delineated$by$a$single$'dollar'$character,$write$a$program
+that$aligns$each$column$of$fields$by$ensuring$that$words$in$each$
+column$are$separated$by$at$least$one$space.
+Further,$allow$for$each$word$in$a$column$to$be$either$left$
+justified,$right$justified,$or$center$justified$within$its$column.
+'@.Split("`n")
+
+$arr = @()
+$file | foreach {
+ $line = $_
+ $i = 0
+ $hash = [ordered]@{}
+ $line.split('$') | foreach{
+ $hash["$i"] = "$_"
+ $i++
+ }
+ $arr += @([pscustomobject]$hash)
+}
+$arr | Format-Table -HideTableHeaders -Wrap *
diff --git a/Task/Align-columns/Rebol/align-columns.rebol b/Task/Align-columns/Rebol/align-columns.rebol
new file mode 100644
index 0000000000..4af5a57fd6
--- /dev/null
+++ b/Task/Align-columns/Rebol/align-columns.rebol
@@ -0,0 +1,58 @@
+Rebol [
+ Title: "Align Columns"
+ URL: http://rosettacode.org/wiki/Align_columns
+]
+
+specimen: {Given$a$text$file$of$many$lines,$where$fields$within$a$line$
+are$delineated$by$a$single$'dollar'$character,$write$a$program
+that$aligns$each$column$of$fields$by$ensuring$that$words$in$each$
+column$are$separated$by$at$least$one$space.
+Further,$allow$for$each$word$in$a$column$to$be$either$left$
+justified,$right$justified,$or$center$justified$within$its$column.}
+
+; Parse specimen into data grid.
+data: copy []
+
+either function? get/any 'split [
+ ;; Rebol 3 version
+ foreach line split-lines specimen [
+ append/only data split line #"$"
+ ]
+][ ;; Rebol 2 version
+ foreach line parse specimen to-string lf [ ; Break into lines.
+ append/only data parse line "$" ; Break into columns.
+ ]
+]
+; Compute independent widths for each column.
+widths: copy [] insert/dup widths 0 length? data/1
+foreach line data [
+ forall line [
+ i: index? line
+ widths/:i: max widths/:i length? line/1
+ ]
+]
+
+pad: func [n /local x][x: copy "" insert/dup x " " n x]
+; These formatting functions are passed as arguments to entable.
+right: func [n s][rejoin [pad n - length? s s]]
+left: func [n s][rejoin [s pad n - length? s]]
+centre: func [n s /local h][
+ h: round/down (n - length? s) / 2
+ rejoin [pad h s pad n - h - length? s]
+]
+
+; Display data as table.
+entable: func [data format] [
+ foreach line data [
+ forall line [
+ prin rejoin [format pick widths index? line line/1 " "]
+ ]
+ print ""
+ ]
+]
+
+; Format data table.
+foreach i [left centre right] [
+ print ["^/Align" i "...^/"]
+ entable data get i
+]
diff --git a/Task/Align-columns/VBScript/align-columns.vbs b/Task/Align-columns/VBScript/align-columns.vbs
new file mode 100644
index 0000000000..902397b02e
--- /dev/null
+++ b/Task/Align-columns/VBScript/align-columns.vbs
@@ -0,0 +1,62 @@
+' Align columns - RC - VBScript
+ Const nr=16, nc=16
+ ReDim d(nc),t(nr), wor(nr,nc)
+ i=i+1: t(i) = "Given$a$text$file$of$many$lines,$where$fields$within$a$line$"
+ i=i+1: t(i) = "are$delineated$by$a$single$'dollar'$character,$write$a$program"
+ i=i+1: t(i) = "that$aligns$each$column$of$fields$by$ensuring$that$words$in$each$"
+ i=i+1: t(i) = "column$are$separated$by$at$least$one$space."
+ i=i+1: t(i) = "Further,$allow$for$each$word$in$a$column$To$be$either$left$"
+ i=i+1: t(i) = "justified,$right$justified,$or$center$justified$within$its$column."
+ For r=1 to nr
+ If t(r)="" Then Exit For
+ w=xRTrim(t(r),"$")
+ m=Split(w,"$")
+ For c=1 To UBound(m)+1
+ wor(r,c)=m(c-1)
+ If Len(wor(r,c))>d(c) Then d(c)=Len(wor(r,c))
+ Next 'c
+ If c>cols Then cols=c
+ Next 'r
+ rows=r-1
+ tt=Array("Left","Right","Center")
+ For n=1 To 3
+ Wscript.Echo
+ Wscript.Echo "*****" & tt(n-1) & "*****"
+ For r=1 To rows
+ w=""
+ For c=1 To cols
+ x=wor(r,c): s=Space(d(c))
+ Select Case n
+ Case 1: w=w &" "& Left (x & s,d(c))
+ Case 2: w=w &" "& Right (s & x,d(c))
+ Case 3: w=w &" "& xCentre(x,d(c)," ")
+ End Select 'n
+ Next 'c
+ Wscript.Echo Mid(w,2)
+ Next 'r
+ Next 'n
+
+Function xCentre(c, n, Pad)
+ Dim j
+ If n > Len(c) Then
+ j = (n - Len(c)) \ 2
+ If (n - Len(c)) Mod 2 <> 0 Then j = j + 1
+ xCentre = Mid(String(j, Pad) & c & String(j, Pad), 1, n)
+ Else
+ xCentre = c
+ End If
+End Function 'xCentre
+
+Function xRTrim(c, Pad)
+ Dim i2, l, cc
+ cc = "": l = Len(c)
+ If l > 0 Then
+ i2 = l
+ Do While (Mid(c, i2, 1) = Pad And i2 > 1)
+ i2 = i2 - 1
+ Loop
+ If i2 = 1 And Mid(c, i2, 1) = Pad Then i2 = 0
+ If i2 > 0 Then cc = Mid(c, 1, i2)
+ End If
+ xRTrim = cc
+End Function 'xRTrim
diff --git a/Task/Aliquot-sequence-classifications/Crystal/aliquot-sequence-classifications.cr b/Task/Aliquot-sequence-classifications/Crystal/aliquot-sequence-classifications.cr
new file mode 100644
index 0000000000..5c4c4e4100
--- /dev/null
+++ b/Task/Aliquot-sequence-classifications/Crystal/aliquot-sequence-classifications.cr
@@ -0,0 +1,35 @@
+def sum_proper_divisors (n)
+ z = n.class.zero
+ (z+1..n//2).sum(z) {|i| n % i == 0 ? i : 0 }
+end
+
+def aliquot (n)
+ seq = [n]
+ limit = 2_i64**47
+ 15.times do
+ n = sum_proper_divisors(n)
+ case n
+ when 0 then return { "terminating", seq << n }
+ when .>(limit) then return { "non-terminating", seq << n }
+ when seq[0] then return { case seq.size
+ when 1 then "perfect"
+ when 2 then "amicable"
+ else "sociable"
+ end, seq }
+ when seq.last then return { "aspiring", seq }
+ when .in?(seq) then return { "cyclic", seq << n }
+ end
+ seq << n
+ end
+ { "non-terminating", seq }
+end
+
+(1..10).each do |i|
+ kind, seq = aliquot(i)
+ puts "%s: %s" % { kind, seq }
+end
+puts
+[11, 12, 28, 496, 220, 1184, 12496, 1264460, 790, 909, 562, 1064, 1488].each do |i|
+ kind, seq = aliquot(i)
+ puts "%s: %s" % { kind, seq }
+end
diff --git a/Task/Aliquot-sequence-classifications/Pluto/aliquot-sequence-classifications.pluto b/Task/Aliquot-sequence-classifications/Pluto/aliquot-sequence-classifications.pluto
new file mode 100644
index 0000000000..f4301abc48
--- /dev/null
+++ b/Task/Aliquot-sequence-classifications/Pluto/aliquot-sequence-classifications.pluto
@@ -0,0 +1,56 @@
+local int = require "int"
+local fmt = require "fmt"
+require "table2"
+
+$define THRESHOLD = 1 << 47
+
+class classification
+ function __construct(public seq, public aliquot) end
+end
+
+local function classify_sequence(k)
+ assert(k > 0, "K must be positive")
+ local last = k
+ local seq = {k}
+ while true do
+ last = int.divisors(last, true):sum()
+ seq:insert(last)
+ local n = #seq
+ local aliquot = ""
+ if last == 0 then
+ aliquot = "Terminating"
+ elseif n == 2 and last == k then
+ aliquot = "Perfect"
+ elseif n == 3 and last == k then
+ aliquot = "Amicable"
+ elseif n >= 4 and last == k then
+ aliquot = $"Sociable[{n - 1}]"
+ elseif last == seq[n - 1] then
+ aliquot = "Aspiring"
+ elseif n > 3 and (last in seq:slice(2, n - 2)) then
+ local ix = seq:findindex(|e| -> e == last) ?? -1
+ aliquot = $"Cyclic[{n - ix}]"
+ elseif n == 16 or last > THRESHOLD then
+ aliquot = "Non-terminating"
+ end
+ if aliquot != "" then return new classification(seq, aliquot) end
+ end
+end
+
+print("Aliquot classifications - periods for Sociable/Cyclic in square brackets:\n")
+for k = 1, 10 do
+ local c = classify_sequence(k)
+ fmt.print("%2d: %-15s %,s", k, c.aliquot, c.seq)
+end
+
+print()
+local a = {11, 12, 28, 496, 220, 1184, 12496, 1264460, 790, 909, 562, 1064, 1488}
+for a as k do
+ local c = classify_sequence(k)
+ fmt.print("%7d: %-15s %,s", k, c.aliquot, c.seq)
+end
+
+print()
+local k = 15355717786080
+local c = classify_sequence(k)
+fmt.print("%d: %-15s %,s", k, c.aliquot, c.seq)
diff --git a/Task/Aliquot-sequence-classifications/PowerShell/aliquot-sequence-classifications-1.ps1 b/Task/Aliquot-sequence-classifications/PowerShell/aliquot-sequence-classifications-1.ps1
new file mode 100644
index 0000000000..1ffa188a7b
--- /dev/null
+++ b/Task/Aliquot-sequence-classifications/PowerShell/aliquot-sequence-classifications-1.ps1
@@ -0,0 +1,34 @@
+function Get-NextAliquot ( [int]$X )
+ {
+ If ( $X -gt 1 )
+ {
+ $NextAliquot = 0
+ (1..($X/2)).Where{ $x % $_ -eq 0 }.ForEach{ $NextAliquot += $_ }.Where{ $_ }
+ return $NextAliquot
+ }
+ }
+
+function Get-AliquotSequence ( [int]$K, [int]$N )
+ {
+ $X = $K
+ $X
+ (1..($N-1)).ForEach{ $X = Get-NextAliquot $X; $X }
+ }
+
+function Classify-AlliquotSequence ( [int[]]$Sequence )
+ {
+ $K = $Sequence[0]
+ $LastN = $Sequence.Count
+ If ( $Sequence[-1] -eq 0 ) { return "terminating" }
+ If ( $Sequence[-1] -eq 1 ) { return "terminating" }
+ If ( $Sequence[1] -eq $K ) { return "perfect" }
+ If ( $Sequence[2] -eq $K ) { return "amicable" }
+ If ( $Sequence[3..($Sequence.Count-1)] -contains $K ) { return "sociable" }
+ If ( $Sequence[-1] -eq $Sequence[-2] ) { return "aspiring" }
+ If ( $Sequence.Count -gt ( $Sequence | Select -Unique ).Count ) { return "cyclic" }
+ return "non-terminating and non-repeating through N = $($Sequence.Count)"
+ }
+
+(1..10).ForEach{ [string]$_ + " is " + ( Classify-AlliquotSequence -Sequence ( Get-AliquotSequence -K $_ -N 16 ) ) }
+
+( 11, 12, 28, 496, 220, 1184, 790, 909, 562, 1064, 1488 ).ForEach{ [string]$_ + " is " + ( Classify-AlliquotSequence -Sequence ( Get-AliquotSequence -K $_ -N 16 ) ) }
diff --git a/Task/Aliquot-sequence-classifications/PowerShell/aliquot-sequence-classifications-2.ps1 b/Task/Aliquot-sequence-classifications/PowerShell/aliquot-sequence-classifications-2.ps1
new file mode 100644
index 0000000000..33b3d4fa4f
--- /dev/null
+++ b/Task/Aliquot-sequence-classifications/PowerShell/aliquot-sequence-classifications-2.ps1
@@ -0,0 +1,63 @@
+function Get-NextAliquot ( [int]$X )
+ {
+ If ( $X -gt 1 )
+ {
+ $NextAliquot = 1
+ If ( $X -gt 2 )
+ {
+ $XSquareRoot = [math]::Sqrt( $X )
+
+ (2..$XSquareRoot).Where{ $X % $_ -eq 0 }.ForEach{ $NextAliquot += $_ + $x / $_ }
+
+ If ( $XSquareRoot % 1 -eq 0 ) { $NextAliquot -= $XSquareRoot }
+ }
+ return $NextAliquot
+ }
+ }
+
+function Get-AliquotSequence ( [int]$K, [int]$N )
+ {
+ $X = $K
+ $X
+ $i = 1
+ While ( $X -and $i -lt $N )
+ {
+ $i++
+ $Next = Get-NextAliquot $X
+ If ( $Next )
+ {
+ If ( $X -eq $Next )
+ {
+ ($i..$N).ForEach{ $X }
+ $i = $N
+ }
+ Else
+ {
+ $X = $Next
+ $X
+ }
+ }
+ Else
+ {
+ $i = $N
+ }
+ }
+ }
+
+function Classify-AlliquotSequence ( [int[]]$Sequence )
+ {
+ $K = $Sequence[0]
+ $LastN = $Sequence.Count
+ If ( $Sequence[-1] -eq 0 ) { return "terminating" }
+ If ( $Sequence[-1] -eq 1 ) { return "terminating" }
+ If ( $Sequence[1] -eq $K ) { return "perfect" }
+ If ( $Sequence[2] -eq $K ) { return "amicable" }
+ If ( $Sequence[3..($Sequence.Count-1)] -contains $K ) { return "sociable" }
+ If ( $Sequence[-1] -eq $Sequence[-2] ) { return "aspiring" }
+ If ( $Sequence.Count -gt ( $Sequence | Select -Unique ).Count ) { return "cyclic" }
+ return "non-terminating and non-repeating through N = $($Sequence.Count)"
+ }
+
+(1..10).ForEach{ [string]$_ + " is " + ( Classify-AlliquotSequence -Sequence ( Get-AliquotSequence -K $_ -N 16 ) ) }
+
+( 11, 12, 28, 496, 220, 1184, 12496, 1264460, 790, 909, 562, 1064, 1488 ).ForEach{ [string]$_ + " is " + ( Classify-AlliquotSequence -Sequence ( Get-AliquotSequence -K $_ -N 16 ) ) }
diff --git a/Task/Aliquot-sequence-classifications/PowerShell/aliquot-sequence-classifications-3.ps1 b/Task/Aliquot-sequence-classifications/PowerShell/aliquot-sequence-classifications-3.ps1
new file mode 100644
index 0000000000..9999c547fc
--- /dev/null
+++ b/Task/Aliquot-sequence-classifications/PowerShell/aliquot-sequence-classifications-3.ps1
@@ -0,0 +1,90 @@
+function Get-Aliquot
+{
+ [CmdletBinding()]
+ [OutputType([PScustomObject])]
+ Param
+ (
+ [Parameter(Mandatory=$true,
+ ValueFromPipeline=$true,
+ ValueFromPipelineByPropertyName=$true)]
+ [int]
+ $InputObject
+ )
+
+ Begin
+ {
+ function Get-NextAliquot ([int]$X)
+ {
+ if ($X -gt 1)
+ {
+ $nextAliquot = 1
+
+ if ($X -gt 2)
+ {
+ $xSquareRoot = [Math]::Sqrt($X)
+
+ 2..$xSquareRoot | Where-Object {$X % $_ -eq 0} | ForEach-Object {$nextAliquot += $_ + $x / $_}
+
+ if ($xSquareRoot % 1 -eq 0) {$nextAliquot -= $xSquareRoot}
+ }
+
+ $nextAliquot
+ }
+ }
+
+ function Get-AliquotSequence ([int]$K, [int]$N)
+ {
+ $X = $K
+ $X
+ $i = 1
+
+ while ($X -and $i -lt $N)
+ {
+ $i++
+ $next = Get-NextAliquot $X
+
+ if ($next)
+ {
+ if ($X -eq $next)
+ {
+ $i..$N | ForEach-Object {$X}
+ $i = $N
+ }
+ else
+ {
+ $X = $next
+ $X
+ }
+ }
+ else
+ {
+ $i = $N
+ }
+ }
+ }
+
+ function Classify-AlliquotSequence ([int[]]$Sequence)
+ {
+ $k = $Sequence[0]
+
+ if ($Sequence[-1] -eq 0) {return "terminating"}
+ if ($Sequence[-1] -eq 1) {return "terminating"}
+ if ($Sequence[1] -eq $k) {return "perfect" }
+ if ($Sequence[2] -eq $k) {return "amicable" }
+ if ($Sequence[3..($Sequence.Count-1)] -contains $k) {return "sociable" }
+ if ($Sequence[-1] -eq $Sequence[-2] ) {return "aspiring" }
+ if ($Sequence.Count -gt ($Sequence | Select -Unique).Count ) {return "cyclic" }
+
+ return "non-terminating and non-repeating through N = $($Sequence.Count)"
+ }
+ }
+ Process
+ {
+ $_ | ForEach-Object {
+ [PSCustomObject]@{
+ Number = $_
+ Classification = (Classify-AlliquotSequence -Sequence (Get-AliquotSequence -K $_ -N 16))
+ }
+ }
+ }
+}
diff --git a/Task/Aliquot-sequence-classifications/PowerShell/aliquot-sequence-classifications-4.ps1 b/Task/Aliquot-sequence-classifications/PowerShell/aliquot-sequence-classifications-4.ps1
new file mode 100644
index 0000000000..d6e159aeda
--- /dev/null
+++ b/Task/Aliquot-sequence-classifications/PowerShell/aliquot-sequence-classifications-4.ps1
@@ -0,0 +1,5 @@
+$oneToTen = 1..10 | Get-Aliquot
+$selected = 11, 12, 28, 496, 220, 1184, 12496, 1264460, 790, 909, 562, 1064, 1488 | Get-Aliquot
+
+$numbers = $oneToTen, $selected
+$numbers
diff --git a/Task/Almkvist-Giullera-formula-for-pi/Ada/almkvist-giullera-formula-for-pi.adb b/Task/Almkvist-Giullera-formula-for-pi/Ada/almkvist-giullera-formula-for-pi.adb
new file mode 100644
index 0000000000..400094aff2
--- /dev/null
+++ b/Task/Almkvist-Giullera-formula-for-pi/Ada/almkvist-giullera-formula-for-pi.adb
@@ -0,0 +1,94 @@
+-- Big_Reals is an Ada 2022 unit
+with Ada.Numerics.Big_Numbers.Big_Reals;
+with Ada.Text_IO;
+
+use Ada.Numerics.Big_Numbers.Big_Reals;
+
+procedure Almkvist_Giullera is
+
+ function "+" (B : Big_Real; A : Integer) return Big_Real is (B + To_Real (A));
+ function "*" (A : Integer; B : Big_Real) return Big_Real is (To_Real (A) * B);
+ B0 : constant Big_Real := To_Real (0);
+ B1 : constant Big_Real := B0 + 1;
+
+ function Factorial (N : Big_Real) return Big_Real
+ is
+ I : Big_Real := N;
+ F : Big_Real := B1;
+ begin
+ while I > B1 loop
+ F := F * I;
+ I := I - B1;
+ end loop;
+
+ return F;
+ end Factorial;
+
+ function F (N : Big_Real) return Big_Real renames Factorial;
+ procedure Put_Line (S : String) renames Ada.Text_IO.Put_Line;
+
+ function Integer_Term (N : Big_Real) return Big_Real is
+ (32 * F (6 * N) / (3 * F (N) ** 6) * (532 * N ** 2 + 126 * N + 9));
+
+ procedure Show_Integer_Terms (N : Positive) is
+ begin
+ for I in 0 .. N - 1 loop
+ Put_Line ("Almkvist-Giullera integer term "
+ & I'Image & " is "
+ & To_String (Integer_Term (To_Real (I)), Aft => 0));
+ end loop;
+ end Show_Integer_Terms;
+
+ -- Use Newton's Method
+ function Sqrt (N : Big_Real; Precision : Positive) return Big_Real is
+ Diff : Big_Real := To_Real (10) ** (-Precision);
+ Estimate : Big_Real := B0;
+ Next : Big_Real := N;
+ begin
+ while abs (Next - Estimate) > Diff loop
+ Estimate := Next;
+ Next := Estimate - (Estimate ** 2 - N) / (2 * Estimate);
+ -- Nasty hack to limit precision. Otherwise there is a storage error.
+ Next := From_String (To_String (Next, Aft => Precision + 2));
+ end loop;
+
+ return Estimate;
+ end Sqrt;
+
+ function Estimate_Pi (N : Integer; Precision : Positive) return Big_Real is
+ Sum : Big_Real := B0;
+ begin
+ for I in 0 .. N loop
+ Sum := Sum + Integer_Term (To_Real (I)) / To_Real (10) ** (6 * I + 3);
+ Sum := From_String (To_String (Sum, Aft => Precision + 2));
+ end loop;
+
+ return B1 / Sqrt (Sum, Precision + 2);
+ end Estimate_Pi;
+
+ function Compute_Pi (Precision : Positive) return Big_Real is
+ Diff : constant Big_Real := To_Real (10) ** (-Precision);
+ Pi_Estimate : Big_Real := B0;
+ Next : Big_Real := B1;
+ N : Integer := 1;
+ begin
+ while abs (Next - Pi_Estimate) > Diff loop
+ N := N * 2;
+ Pi_Estimate := Next;
+ Next := Estimate_Pi (N, Precision);
+ end loop;
+
+ return Pi_Estimate;
+ end Compute_Pi;
+
+ procedure Show_Pi (Precision : Positive) is
+ Pi : constant Big_Real := Compute_Pi (Precision);
+ begin
+ Put_Line ("Pi to " & Precision'Image & " places is "
+ & To_String (Pi, Aft => Precision));
+ end Show_Pi;
+
+begin
+ Show_Integer_Terms (10);
+ Show_Pi (70);
+end almkvist_giullera;
diff --git a/Task/Almkvist-Giullera-formula-for-pi/FutureBasic/almkvist-giullera-formula-for-pi.basic b/Task/Almkvist-Giullera-formula-for-pi/FutureBasic/almkvist-giullera-formula-for-pi.basic
new file mode 100644
index 0000000000..87aaa6d0a3
--- /dev/null
+++ b/Task/Almkvist-Giullera-formula-for-pi/FutureBasic/almkvist-giullera-formula-for-pi.basic
@@ -0,0 +1,139 @@
+//
+// FutureBasic 7.0.35 — Almkvist–Giullera PI
+//
+// September 2025, R.W.
+
+include "mpfr.incl"
+
+long PRECISION
+long n
+
+// Almkvist–Giullera PI estimate via MPFR (256-bit).
+//
+// 1 / π² = 32 × Σ (from n = 0 to ∞) [ (6n)! / (3 × (n!)⁶) × ¬
+// (532n² + 126n + 9) × 1 / (10^(6n + 3)) ]
+
+void local fn AG_Pi256_Compute ( AgPI as mpfr_t )
+ long tmp
+ CFStringRef pLine
+ Boolean iterating = _True
+
+ mpz_t t1, t2, t3
+ mpfr_t f1, f2, sum, prev, diff, epsilon
+
+ // Init big integers
+ mpz_init( t1 )
+ mpz_init( t2 )
+ mpz_init( t3 )
+
+ // Init MPFR floats at 256 bits
+
+ mpfr_init2( f1, PRECISION )
+ mpfr_init2( f2, PRECISION )
+ mpfr_init2( sum, PRECISION )
+ mpfr_init2( prev, PRECISION )
+ mpfr_init2( diff, PRECISION )
+ mpfr_init2( epsilon, PRECISION )
+
+ // Looking at accuracy of 70 decimal digits
+ // Set epsilon to = 10^-70
+
+ fn mpfr_set_ui( epsilon, 10, MPFR_RNDN)
+ fn mpfr_pow_ui( epsilon, epsilon, 70, MPFR_RNDN )
+ fn mpfr_ui_div( epsilon, 1, epsilon, MPFR_RNDN )
+
+ // sum = 0
+ fn mpfr_set_ui( sum, 0, MPFR_RNDN )
+
+ // Sum_{n = 0..kTerms}
+ // ( (6n)! * (532 n^2 + 126 n + 9) * 2^5 ) / ( 3 * (n!)^6 * 10^(6n+3) )
+ //
+ While iterating
+ mpz_fac_ui( t1, 6 * n ) // t1 = (6n)!
+ // // t2 = 532 n^2 + 126 n + 9
+ mpz_ui_pow_ui( t2, n, 2 ) // t2 = n^2
+ mpz_mul_ui( t2, t2, 532 ) // 532 n^2
+ mpz_set_ui( t3, n ) // t3 = n
+ mpz_mul_ui( t3, t3, 126 ) // 126 n
+ mpz_add( t2, t2, t3 ) // 532 n^2 + 126 n
+ mpz_add_ui( t2, t2, 9 ) // + 9
+ // // t3 = 3 * (n!)^6
+ mpz_fac_ui( t3, n ) // t3 = n!
+ mpz_pow_ui( t3, t3, 6 ) // (n!)^6
+ mpz_mul_ui( t3, t3, 3 ) // 3 * (n!)^6
+ // // t1 = t1 * t2 * 2^5 / t3
+ mpz_mul( t1, t1, t2 ) // t1 = t1 * t2
+ mpz_mul_2exp( t1, t1, 5 ) // t1 = t1 * t1 ^5
+ mpz_divexact( t1, t1, t3 ) // t1 = t1 / t3
+
+ // Print t1 if n less than 10
+ // to fullfil Rosetta Task requirement
+ if n < 10
+ pLine = @""
+ pLine = fn mpz_cf(10,t1)
+ pLine = concat(str(n),@" | ",pLine)
+ print @ pLine
+ if n == 9
+ print@
+ print@ "Estimating PI.."
+ print @
+ end if
+ end if
+
+ // f1 = t1 / 10^(6n+3)
+ fn mpfr_set_z( f1, t1, MPFR_RNDN )
+ tmp = 6 * n + 3
+ fn mpfr_set_ui( f2, 10, MPFR_RNDN )
+ fn mpfr_pow_ui( f2, f2, tmp, MPFR_RNDN )
+ fn mpfr_div( f1, f1, f2, MPFR_RNDN )
+ // sum += f1
+ fn mpfr_add( sum, sum, f1, MPFR_RNDN )
+ // find the difference between previous sum and current
+ fn mpfr_sub( diff, sum, prev, MPFR_RNDN)
+ //mpfr_set_ui(prev, 10, MPFR_RNDN ) //sum -> prev
+ fn mpfr_set(prev, sum, MPFR_RNDN)
+
+ // if (sum - prev) < epsilon, then we're done
+
+ if (fn mpfr_cmpabs( diff, epsilon ) < 0 ) then iterating = _False
+ fn mpfr_sqrt( f2, sum, MPFR_RNDN )
+ fn mpfr_ui_div( AgPI, 1, f2, MPFR_RNDN ) // 1 / sqrt(sum)
+ n++
+ wend
+
+ // Final output
+ print @fn mpfr_cf2(71, AgPi, MPFR_RNDN)
+ print@
+ print @"70 decimal digits accuracy achieved after ";n;" iterations."
+
+ // Cleanup
+ mpfr_clear( epsilon )
+ mpfr_clear( diff )
+ mpfr_clear( prev )
+ mpfr_clear( sum )
+ mpfr_clear( f2 )
+ mpfr_clear( f1 )
+ mpz_clear( t3 )
+ mpz_clear( t2 )
+ mpz_clear( t1 )
+
+end fn
+
+//------------------ Main
+window 1, @"Almkvist–Giullera PI"
+print@
+print " n | Integer of Nth term"
+printf fn StringByPaddingToLength( @"", 48, @"-", 0 )
+
+PRECISION = 256
+mpfr_t AgPi
+mpfr_init2( AgPI, PRECISION )
+
+fn AG_Pi256_Compute ( AgPI )
+
+mpfr_clear( AgPI )
+
+
+HandleEvents
+
+//
diff --git a/Task/Almkvist-Giullera-formula-for-pi/Phix/almkvist-giullera-formula-for-pi.phix b/Task/Almkvist-Giullera-formula-for-pi/Phix/almkvist-giullera-formula-for-pi.phix
index 0cb0773019..42386d1df4 100644
--- a/Task/Almkvist-Giullera-formula-for-pi/Phix/almkvist-giullera-formula-for-pi.phix
+++ b/Task/Almkvist-Giullera-formula-for-pi/Phix/almkvist-giullera-formula-for-pi.phix
@@ -1,53 +1,51 @@
-(phixonline)-->
- with javascript_semantics
- requires("1.0.0")
- include mpfr.e
- mpfr_set_default_precision(-70)
+with javascript_semantics
+requires("1.0.0")
+include mpfr.e
+mpfr_set_default_precision(-70)
- function almkvistGiullera(integer n, bool bPrint)
- mpz {t1,t2,ip} = mpz_inits(3)
- mpz_fac_ui(t1,6*n)
- mpz_mul_si(t1,t1,32) -- t1:=2^5*(6n)!
- mpz_fac_ui(t2,n)
- mpz_pow_ui(t2,t2,6)
- mpz_mul_si(t2,t2,3) -- t2:=3*(n!)^6
- mpz_mul_si(ip,t1,532*n*n+126*n+9) -- ip:=t1*(532n^2+126n+9)
- mpz_fdiv_q(ip,ip,t2) -- ip:=ip/t2
- integer pw := 6*n+3
- mpz_ui_pow_ui(t1,10,pw) -- t1 := 10^(6n+3)
- mpq tm = mpq_init_set_z(ip,t1) -- tm := rat(ip/t1)
- if bPrint then
- string ips = mpz_get_str(ip),
- tms = mpfr_get_fixed(mpfr_init_set_q(tm),50)
- tms = trim_tail(tms,"0")
- printf(1,"%d %44s %3d %s\n", {n, ips, -pw, tms})
- end if
- return tm
- end function
+function almkvistGiullera(integer n, bool bPrint)
+ mpz {t1,t2,ip} = mpz_inits(3)
+ mpz_fac_ui(t1,6*n)
+ mpz_mul_si(t1,t1,32) -- t1:=2^5*(6n)!
+ mpz_fac_ui(t2,n)
+ mpz_pow_ui(t2,t2,6)
+ mpz_mul_si(t2,t2,3) -- t2:=3*(n!)^6
+ mpz_mul_si(ip,t1,532*n*n+126*n+9) -- ip:=t1*(532n^2+126n+9)
+ mpz_fdiv_q(ip,ip,t2) -- ip:=ip/t2
+ integer pw := 6*n+3
+ mpz_ui_pow_ui(t1,10,pw) -- t1 := 10^(6n+3)
+ mpq tm = mpq_init_set_z(ip,t1) -- tm := rat(ip/t1)
+ if bPrint then
+ string ips = mpz_get_str(ip),
+ tms = mpfr_get_fixed(mpfr_init_set_q(tm),50)
+ tms = trim_tail(tms,"0")
+ printf(1,"%d %44s %3d %s\n", {n, ips, -pw, tms})
+ end if
+ return tm
+end function
- constant hdr = "N --------------- Integer portion ------------- Pow ----------------- Nth term (50 dp) -----------------"
- printf(1,"%s\n%s\n",{hdr,repeat('-',length(hdr))})
- for n=0 to 9 do
- {} = almkvistGiullera(n, true)
- end for
+constant hdr = "N --------------- Integer portion ------------- Pow ----------------- Nth term (50 dp) -----------------"
+printf(1,"%s\n%s\n",{hdr,repeat('-',length(hdr))})
+for n=0 to 9 do
+ {} = almkvistGiullera(n, true)
+end for
- mpq {res,prev,z} = mpq_inits(3),
- prec = mpq_init_set_str(sprintf("1/1%s",repeat('0',70)))
- integer n = 0
- while true do
- mpq term := almkvistGiullera(n, false)
- mpq_add(res,res,term)
- mpq_sub(z,res,prev)
- mpq_abs(z,z)
- if mpq_cmp(z,prec) < 0 then exit end if
- mpq_set(prev,res)
- n += 1
- end while
- mpq_inv(res,res)
- mpfr pi = mpfr_init_set_q(res)
- mpfr_sqrt(pi,pi)
- printf(1,"\nCalculation of pi took %d iterations using the Almkvist-Giullera formula.\n\n",n)
- printf(1,"Pi to 70 d.p.: %s\n",mpfr_get_fixed(pi,70))
- mpfr_const_pi(pi)
- printf(1,"Pi (builtin) : %s\n",mpfr_get_fixed(pi,70))
-
- -- demo\rosetta\Arithmetic_evaluation.exw
- with javascript_semantics
+-- demo\rosetta\Arithmetic_evaluation.exw
+sequence opstack = {} -- atom elements are literals,
+ -- sequence elements are subexpressions
+ -- on completion length(opstack) should be 1
+object token
- sequence opstack = {} -- atom elements are literals,
- -- sequence elements are subexpressions
- -- on completion length(opstack) should be 1
- object token
+constant p_p_op = -1, -- expressions stored as p1,p2,op
+ p_op_p = 0, -- expressions stored as p1,op,p2
+ op_p_p = +1, -- expressions stored as op,p1,p2
+ opp = op_p_p
- constant op_p_p = 1 -- 1: expressions stored as op,p1,p2
- -- p_op_p -- 0: expressions stored as p1,op,p2
- -- p_p_op -- -1: expressions stored as p1,p2,op
+object op = 0 -- 0 if none, else "+", "-", "*", "/", "^", "%", or "u-"
- object op = 0 -- 0 if none, else "+", "-", "*", "/", "^", "%", or "u-"
+string s -- the expression being parsed
+integer ch
+integer sidx
- string s -- the expression being parsed
- integer ch
- integer sidx
+procedure err(string msg)
+ crash("%s\n%s^ %s\n\nPressEnter...",{s,repeat(' ',sidx-1),msg})
+end procedure
- procedure err(string msg)
- printf(1,"%s\n%s^ %s\n\nPressEnter...",{s,repeat(' ',sidx-1),msg})
- {} = wait_key()
- abort(0)
- end procedure
+procedure nxtch(object msg="eof")
+ sidx += 1
+ if sidx>length(s) then
+ if string(msg) then err(msg) end if
+ ch = -1
+ else
+ ch = s[sidx]
+ end if
+end procedure
- procedure nxtch(object msg="eof")
- sidx += 1
- if sidx>length(s) then
- if string(msg) then err(msg) end if
- ch = -1
- else
- ch = s[sidx]
- end if
- end procedure
+procedure skipspaces()
+ while find(ch," \t\r\n") do nxtch(0) end while
+end procedure
- procedure skipspaces()
- while find(ch,{' ','\t','\r','\n'})!=0 do nxtch(0) end while
- end procedure
+procedure get_token()
+ skipspaces()
+ if ch=-1 then token = "eof" return end if
+ if ch>='0' and ch<='9' then
+ atom n = ch-'0'
+ while 1 do
+ nxtch(0)
+ if ch<'0' or ch>'9' then exit end if
+ n = n*10+(ch-'0')
+ end while
+ if ch='.' then
+ integer decimal = 1
+ atom fraction = 0
+ while true do
+ nxtch(0)
+ if ch<'0' or ch>'9' then exit end if
+ fraction = fraction*10 + (ch-'0')
+ decimal *= 10
+ end while
+ n += fraction/decimal
+ end if
+-- if find(ch,"eE") then -- you get the idea
+-- end if
+ token = n
+ return
+ end if
+ if find(ch,"+-/*()^%")=0 then err("syntax error") end if
+ token = s[sidx..sidx]
+ nxtch(0)
+ return
+end procedure
- procedure get_token()
- atom n, fraction
- integer dec
- skipspaces()
- if ch=-1 then token = "eof" return end if
- if ch>='0' and ch<='9' then
- n = ch-'0'
- while 1 do
- nxtch(0)
- if ch<'0' or ch>'9' then exit end if
- n = n*10+ch-'0'
- end while
- if ch='.' then
- dec = 1
- fraction = 0
- while 1 do
- nxtch(0)
- if ch<'0' or ch>'9' then exit end if
- fraction = fraction*10 + ch-'0'
- dec *= 10
- end while
- n += fraction/dec
- end if
- -- if find(ch,"eE") then -- you get the idea
- -- end if
- token = n
- return
- end if
- if find(ch,"+-/*()^%")=0 then err("syntax error") end if
- token = s[sidx..sidx]
- nxtch(0)
- return
- end procedure
+procedure Match(string t)
+ if token!=t then err(t&" expected") end if
+ get_token()
+end procedure
- procedure Match(string t)
- if token!=t then err(t&" expected") end if
- get_token()
- end procedure
+procedure PopFactor()
+ object p1, p2 = opstack[$], f
+ if op="u-" then
+ p1 = 0
+ else
+ opstack = opstack[1..$-1]
+ p1 = opstack[$]
+ end if
+ switch opp do
+ case op_p_p: f = {op,p1,p2}
+ case p_op_p: f = {p1,op,p2}
+ case p_p_op: f = {p1,p2,op}
+ end switch
+ opstack[$] = f
+ op = 0
+end procedure
- procedure PopFactor()
- object p1, p2 = opstack[$]
- if op="u-" then
- p1 = 0
- else
- opstack = opstack[1..$-1]
- p1 = opstack[$]
- end if
- if op_p_p=1 then
- opstack[$] = {op,p1,p2} -- op_p_p
- elsif op_p_p=0 then
- opstack[$] = {p1,op,p2} -- p_op_p
- else -- -1
- opstack[$] = {p1,p2,op} -- p_p_op
- end if
- op = 0
- end procedure
+procedure PushFactor(atom t)
+ if op!=0 then PopFactor() end if
+ opstack = append(opstack,t)
+end procedure
- procedure PushFactor(atom t)
- if op!=0 then PopFactor() end if
- opstack = append(opstack,t)
- end procedure
+procedure PushOp(string t)
+ if op!=0 then PopFactor() end if
+ op = t
+end procedure
- procedure PushOp(string t)
- if op!=0 then PopFactor() end if
- op = t
- end procedure
+forward procedure Expr(integer p)
- forward procedure Expr(integer p)
+procedure Factor()
+ if atom(token) then
+ PushFactor(token)
+ if ch!=-1 then
+ get_token()
+ end if
+ elsif token="+" then -- (ignore)
+ nxtch()
+ Factor()
+ elsif token="-" then
+ get_token()
+-- Factor()
+ Expr(3) -- makes "-3^2" yield -9 (ie -(3^2)) not 9 (ie (-3)^2).
+ if op!=0 then PopFactor() end if
+ if integer(opstack[$]) then
+ opstack[$] = -opstack[$]
+ else
+ PushOp("u-")
+ end if
+ elsif token="(" then
+ get_token()
+ Expr(0)
+ Match(")")
+ else
+ err("syntax error")
+ end if
+end procedure
- procedure Factor()
- if atom(token) then
- PushFactor(token)
- if ch!=-1 then
- get_token()
- end if
- elsif token="+" then -- (ignore)
- nxtch()
- Factor()
- elsif token="-" then
- get_token()
- -- Factor()
- Expr(3) -- makes "-3^2" yield -9 (ie -(3^2)) not 9 (ie (-3)^2).
- if op!=0 then PopFactor() end if
- if integer(opstack[$]) then
- opstack[$] = -opstack[$]
- else
- PushOp("u-")
- end if
- elsif token="(" then
- get_token()
- Expr(0)
- Match(")")
- else
- err("syntax error")
- end if
- end procedure
+constant {operators,
+ precedence,
+ associativity} = columnize({{"^",3,0},
+ {"%",2,1},
+ {"*",2,1},
+ {"/",2,1},
+ {"+",1,1},
+ {"-",1,1},
+ $})
- constant {operators,
- precedence,
- associativity} = columnize({{"^",3,0},
- {"%",2,1},
- {"*",2,1},
- {"/",2,1},
- {"+",1,1},
- {"-",1,1},
- $})
+procedure Expr(integer p)
+--
+-- Parse an expression, using precedence climbing.
+--
+-- p is the precedence level we should parse to, eg/ie
+-- 4: Factor only (may as well just call Factor)
+-- 3: "" and ^
+-- 2: "" and *,/,%
+-- 1: "" and +,-
+-- 0: full expression (effectively the same as 1)
+-- obviously, parentheses override any setting of p.
+--
+ Factor()
+ while 1 do
+ integer k = find(token,operators) -- *,/,+,-
+ if k=0 then exit end if
+ integer thisp = precedence[k]
+ if thispprocedure Expr(integer p)
- --
- -- Parse an expression, using precedence climbing.
- --
- -- p is the precedence level we should parse to, eg/ie
- -- 4: Factor only (may as well just call Factor)
- -- 3: "" and ^
- -- 2: "" and *,/,%
- -- 1: "" and +,-
- -- 0: full expression (effectively the same as 1)
- -- obviously, parentheses override any setting of p.
- --
- integer k, thisp
- Factor()
- while 1 do
- k = find(token,operators) -- *,/,+,-
- if k=0 then exit end if
- thisp = precedence[k]
- if thisp<p then exit end if
- get_token()
- Expr(thisp+associativity[k])
- PushOp(operators[k])
- end while
- end procedure
+function evaluate(object s)
+ object lhs, rhs
+ string op
+ if atom(s) then return s end if
+ switch opp do
+ case op_p_p: {op,lhs,rhs} = s
+ case p_op_p: {lhs,op,rhs} = s
+ case p_p_op: {lhs,rhs,op} = s
+ default: ?9/0
+ end switch
+ if sequence(lhs) then lhs = evaluate(lhs) end if
+ if sequence(rhs) then rhs = evaluate(rhs) end if
+ if op="+" then return lhs+rhs
+ elsif op="-" then return lhs-rhs
+ elsif op="*" then return lhs*rhs
+ elsif op="/" then return lhs/rhs
+ elsif op="^" then return power(lhs,rhs)
+ elsif op="%" then return rmdr(lhs,rhs)
+ elsif op="u-" then return -rhs
+ else ?9/0
+ end if
+end function
- function evaluate(object s)
- object lhs, rhs
- string op
- if atom(s) then
- return s
- end if
- if op_p_p=1 then -- op_p_p
- {op,lhs,rhs} = s
- elsif op_p_p=0 then -- p_op_p
- {lhs,op,rhs} = s
- else -- -1 -- p_p_op
- {lhs,rhs,op} = s
- end if
- if sequence(lhs) then lhs = evaluate(lhs) end if
- if sequence(rhs) then rhs = evaluate(rhs) end if
- if op="+" then
- return lhs+rhs
- elsif op="-" then
- return lhs-rhs
- elsif op="*" then
- return lhs*rhs
- elsif op="/" then
- return lhs/rhs
- elsif op="^" then
- return power(lhs,rhs)
- elsif op="%" then
- return remainder(lhs,rhs)
- elsif op="u-" then
- return -rhs
- else
- ?9/0
- end if
- end function
-
- s = "3+4+5+6*7/1*5^2^3" -- 16406262
- sidx = 0
- nxtch()
- get_token()
- Expr(0)
- if op!=0 then PopFactor() end if
- if length(opstack)!=1 then err("some error") end if
- printf(1,"expression: \"%s\"\n",{s})
- puts(1,"AST (flat): ")
- ?opstack[1]
- puts(1,"AST (tree):\n")
- ppEx(opstack[1],{pp_Nest,9999})
- puts(1,"result: ")
- ?evaluate(opstack[1])
- {} = wait_key()
-(quotient,remainder)
- if(r==0) return(self.fcn(q,k,acc.write(k),q.toFloat().sqrt()));
- return(self.fcn(n,k+1+k.isOdd,acc,maxD))
+ q,r:=n.divr(k); // divr-->(quotient,remainder)
+ if(r==0) return(self.fcn(q,k,acc.write(k),q.toFloat().sqrt()));
+ return(self.fcn(n,k+1+k.isOdd,acc,maxD))
}
}(n,2,Sink(List),n.toFloat().sqrt());
m:=acc.reduce('*,1); // mulitply factors
diff --git a/Task/Average-loop-length/Ada/average-loop-length.adb b/Task/Average-loop-length/Ada/average-loop-length.adb
new file mode 100644
index 0000000000..09e9455936
--- /dev/null
+++ b/Task/Average-loop-length/Ada/average-loop-length.adb
@@ -0,0 +1,53 @@
+with Ada.Text_IO; use Ada.Text_IO;
+with Ada.Numerics.Generic_Elementary_Functions;
+with Ada.Numerics.Discrete_Random;
+procedure Avglen is
+ package IIO is new Ada.Text_IO.Integer_IO (Positive); use IIO;
+ package LFIO is new Ada.Text_IO.Float_IO (Long_Float); use LFIO;
+ subtype FactN is Natural range 0..20;
+ TESTS : constant Natural := 1_000_000;
+
+ function Factorial (N : FactN) return Long_Float is
+ Result : Long_Float := 1.0;
+ begin
+ for I in 2..N loop Result := Result * Long_Float(I); end loop;
+ return Result;
+ end Factorial;
+
+ function Analytical (N : FactN) return Long_Float is
+ Sum : Long_Float := 0.0;
+ begin
+ for I in 1..N loop
+ Sum := Sum + Factorial(N) / Factorial(N - I) / Long_Float(N)**I;
+ end loop;
+ return Sum;
+ end Analytical;
+
+ function Experimental (N : FactN) return Long_Float is
+ subtype RandInt is Natural range 1..N;
+ package Random is new Ada.Numerics.Discrete_Random(RandInt);
+ seed : Random.Generator;
+ Num : RandInt;
+ count : Natural := 0;
+ bits : array(RandInt'Range) of Boolean;
+ begin
+ Random.Reset(seed);
+ for run in 1..TESTS loop
+ bits := (others => false);
+ for I in RandInt'Range loop
+ Num := Random.Random(seed); exit when bits(Num);
+ bits(Num) := True; count := count + 1;
+ end loop;
+ end loop;
+ return Long_Float(count)/Long_Float(TESTS);
+ end Experimental;
+
+ A, E, err : Long_Float;
+begin
+ Put_Line(" N avg calc %diff");
+ for I in 1..20 loop
+ A := Analytical(I); E := Experimental(I); err := abs(E-A)/A*100.0;
+ Put(I, Width=>2); Put(E ,Aft=>4, exp=>0); Put(A, Aft=>4, exp=>0);
+ Put(err, Fore=>3, Aft=>3, exp=>0); New_line;
+ end loop;
+end Avglen;
diff --git a/Task/Average-loop-length/Crystal/average-loop-length.cr b/Task/Average-loop-length/Crystal/average-loop-length.cr
new file mode 100644
index 0000000000..713284e441
--- /dev/null
+++ b/Task/Average-loop-length/Crystal/average-loop-length.cr
@@ -0,0 +1,26 @@
+struct Int
+ def factorial
+ raise "only positive" if self < 0
+ (1_i64..self.to_i64).product
+ end
+end
+
+def rand_until_rep (n)
+ rands = {} of Int32 => Bool
+ loop do
+ r = rand(1..n)
+ return rands.size if rands[r]?
+ rands[r] = true
+ end
+end
+
+runs = 1_000_000
+
+puts " N average exp. diff ",
+ "=== ======== ======== ==========="
+(1..20).each do |n|
+ sum_of_runs = runs.times.sum(0_i64) { rand_until_rep(n) }
+ avg = sum_of_runs / runs
+ analytical = (1..n).sum(0.0) {|i| (n.factorial / (n.to_f**i) / (n-i).factorial) }
+ puts "%3d %8.4f %8.4f (%8.4f%%)" % {n, avg, analytical, (avg/analytical - 1)*100}
+end
diff --git a/Task/Average-loop-length/EasyLang/average-loop-length.easy b/Task/Average-loop-length/EasyLang/average-loop-length.easy
index f12cc4ee3c..d036ff7912 100644
--- a/Task/Average-loop-length/EasyLang/average-loop-length.easy
+++ b/Task/Average-loop-length/EasyLang/average-loop-length.easy
@@ -3,7 +3,7 @@ fastfunc average n reps .
len seen[] n
for r to reps
for i = 1 to n
- f[i] = random n
+ f[i] = random 1 n
seen[i] = 0
.
x = 1
diff --git a/Task/Average-loop-length/Pluto/average-loop-length.pluto b/Task/Average-loop-length/Pluto/average-loop-length.pluto
new file mode 100644
index 0000000000..48b0c75253
--- /dev/null
+++ b/Task/Average-loop-length/Pluto/average-loop-length.pluto
@@ -0,0 +1,39 @@
+require "table2"
+local fmt = require "fmt"
+
+local nmax = 20
+
+local function avg(n)
+ local tests = 1e4
+ local sum = 0
+ for _ = 1, tests do
+ local v = table.rep(nmax, false)
+ local x = 1
+ while !v[x] do
+ v[x] = true
+ sum += 1
+ x = math.random(1, n)
+ end
+ end
+ return sum / tests
+end
+
+local function ana(n)
+ if n < 2 then return 1 end
+ local term = 1
+ local sum = 1
+ for i = n, 2, -1 do
+ term *= (i - 1) / n
+ sum += term
+ end
+ return sum
+end
+
+print(" N average analytical (error)")
+print("=== ========= ============ =========")
+for n = 1, nmax do
+ local a = avg(n)
+ local b = ana(n)
+ local e = math.abs(a - b) / b * 100
+ fmt.print("%3d %9.4f %12.4f (%6.2f%%)", n, a, b, e)
+end
diff --git a/Task/Average-loop-length/PowerShell/average-loop-length-1.ps1 b/Task/Average-loop-length/PowerShell/average-loop-length-1.ps1
new file mode 100644
index 0000000000..20b6979f45
--- /dev/null
+++ b/Task/Average-loop-length/PowerShell/average-loop-length-1.ps1
@@ -0,0 +1,59 @@
+function Get-AnalyticalLoopAverage ( [int]$N )
+ {
+ # Expected loop average = sum from i = 1 to N of N! / (N-i)! / N^(N-i+1)
+ # Equivalently, Expected loop average = sum from i = 1 to N of F(i)
+ # where F(N) = 1, and F(i) = F(i+1)*i/N
+
+ $LoopAverage = $Fi = 1
+
+ If ( $N -eq 1 ) { return $LoopAverage }
+
+ ForEach ( $i in ($N-1)..1 )
+ {
+ $Fi *= $i / $N
+ $LoopAverage += $Fi
+ }
+ return $LoopAverage
+ }
+
+function Get-ExperimentalLoopAverage ( [int]$N, [int]$Tests = 100000 )
+ {
+ If ( $N -eq 1 ) { return 1 }
+
+ # Using 0 through N-1 instead of 1 through N for speed and simplicity
+ $NMO = $N - 1
+
+ # Create array to hold mapping function
+ $F = New-Object int[] ( $N )
+
+ $Count = 0
+ $Random = New-Object System.Random
+
+ ForEach ( $Test in 1..$Tests )
+ {
+ # Map each number to a random number
+ ForEach ( $i in 0..$NMO )
+ {
+ $F[$i] = $Random.Next( $N )
+ }
+
+ # For each number...
+ ForEach ( $i in 0..$NMO )
+ {
+ # Add the number to the list
+ $List = @()
+ $Count++
+ $List += $X = $i
+
+ # If loop does not yet exist in list...
+ While ( $F[$X] -notin $List )
+ {
+ # Go to the next mapped number and add it to the list
+ $Count++
+ $List += $X = $F[$X]
+ }
+ }
+ }
+ $LoopAvereage = $Count / $N / $Tests
+ return $LoopAvereage
+ }
diff --git a/Task/Average-loop-length/PowerShell/average-loop-length-2.ps1 b/Task/Average-loop-length/PowerShell/average-loop-length-2.ps1
new file mode 100644
index 0000000000..3729fdebcd
--- /dev/null
+++ b/Task/Average-loop-length/PowerShell/average-loop-length-2.ps1
@@ -0,0 +1,12 @@
+# Display results for N = 1 through 20
+ForEach ( $N in 1..20 )
+ {
+ $AnalyticalAverage = Get-AnalyticalLoopAverage $N
+ $ExperimentalAverage = Get-ExperimentalLoopAverage $N
+ [pscustomobject] @{
+ N = $N.ToString().PadLeft( 2, ' ' )
+ Analytical = $AnalyticalAverage.ToString( '0.00000000' )
+ Experimental = $ExperimentalAverage.ToString( '0.00000000' )
+ 'Error (%)' = ( [math]::Abs( $AnalyticalAverage - $ExperimentalAverage ) / $AnalyticalAverage * 100 ).ToString( '0.00000000' )
+ }
+ }
diff --git a/Task/Average-loop-length/VBScript/average-loop-length.vbs b/Task/Average-loop-length/VBScript/average-loop-length.vbs
new file mode 100644
index 0000000000..e23bd4d744
--- /dev/null
+++ b/Task/Average-loop-length/VBScript/average-loop-length.vbs
@@ -0,0 +1,48 @@
+Const MAX = 20
+Const ITER = 100000
+
+Function expected(n)
+ Dim sum
+ ni=n
+ For i = 1 To n
+ sum = sum + fact(n) / ni / fact(n-i)
+ ni=ni*n
+ Next
+ expected = sum
+End Function
+
+Function test(n )
+ Dim coun,x,bits
+ For i = 1 To ITER
+ x = 1
+ bits = 0
+ Do While Not bits And x
+ count = count + 1
+ bits = bits Or x
+ x =shift(Int(n * Rnd()))
+ Loop
+ Next
+ test = count / ITER
+End Function
+
+'VBScript formats numbers but does'nt align them!
+function rf(v,n,s) rf=right(string(n,s)& v,n):end function
+
+'some precalculations to speed things up...
+dim fact(20),shift(20)
+fact(0)=1:shift(0)=1
+for i=1 to 20
+ fact(i)=i*fact(i-1)
+ shift(i)=2*shift(i-1)
+next
+
+Dim n
+Wscript.echo "For " & ITER &" iterations"
+Wscript.Echo " n avg. exp. (error%)"
+Wscript.Echo "== ====== ====== =========="
+For n = 1 To MAX
+ av = test(n)
+ ex = expected(n)
+ Wscript.Echo rf(n,2," ")& " "& rf(formatnumber(av, 4),7," ") & " "& _
+ rf(formatnumber(ex,4),6," ")& " ("& rf(Formatpercent(1 - av / ex,4),8," ") & ")"
+Next
diff --git a/Task/Averages-Arithmetic-mean/Ada/averages-arithmetic-mean.adb b/Task/Averages-Arithmetic-mean/Ada/averages-arithmetic-mean.adb
new file mode 100644
index 0000000000..74ae542c0c
--- /dev/null
+++ b/Task/Averages-Arithmetic-mean/Ada/averages-arithmetic-mean.adb
@@ -0,0 +1,22 @@
+with Ada.Float_Text_Io; use Ada.Float_Text_Io;
+with Ada.Text_IO; use Ada.Text_IO;
+
+procedure Mean_Main is
+ type Vector is array (Positive range <>) of Float;
+ function Mean (Item : Vector) return float with pre => Item'length > 0;
+ function Mean (Item : Vector) return Float is
+ Sum : Float := 0.0;
+ begin
+ for I in Item'range loop
+ Sum := Sum + Item(I);
+ end loop;
+ return Sum / Float(Item'Length);
+ end Mean;
+ A : Vector := (3.0, 1.0, 4.0, 1.0, 5.0, 9.0);
+begin
+ Put(Item => Mean (A), Fore => 1, Exp => 0);
+ New_Line;
+ -- test for zero length vector
+ Put(Item => Mean(A (1..0)), Fore => 1, Exp => 0);
+ New_Line;
+end Mean_Main;
diff --git a/Task/Averages-Arithmetic-mean/COBOL/averages-arithmetic-mean-1.cob b/Task/Averages-Arithmetic-mean/COBOL/averages-arithmetic-mean-1.cob
new file mode 100644
index 0000000000..43f1b8f9ff
--- /dev/null
+++ b/Task/Averages-Arithmetic-mean/COBOL/averages-arithmetic-mean-1.cob
@@ -0,0 +1 @@
+FUNCTION MEAN(some-table (ALL))
diff --git a/Task/Averages-Arithmetic-mean/COBOL/averages-arithmetic-mean-2.cob b/Task/Averages-Arithmetic-mean/COBOL/averages-arithmetic-mean-2.cob
new file mode 100644
index 0000000000..0afbedd5dd
--- /dev/null
+++ b/Task/Averages-Arithmetic-mean/COBOL/averages-arithmetic-mean-2.cob
@@ -0,0 +1,28 @@
+ IDENTIFICATION DIVISION.
+ PROGRAM-ID. find-mean.
+
+ DATA DIVISION.
+ LOCAL-STORAGE SECTION.
+ 01 i PIC 9(4).
+
+ 01 summ USAGE FLOAT-LONG.
+
+ LINKAGE SECTION.
+ 01 nums-area.
+ 03 nums-len PIC 9(4).
+ 03 nums USAGE FLOAT-LONG
+ OCCURS 0 TO 1000 TIMES
+ DEPENDING ON nums-len.
+
+ 01 result USAGE FLOAT-LONG.
+
+ PROCEDURE DIVISION USING nums-area, result.
+ IF nums-len = 0
+ MOVE 0 TO result
+ GOBACK
+ END-IF
+
+ DIVIDE FUNCTION SUM(nums (ALL)) BY nums-len GIVING result
+
+ GOBACK
+ .
diff --git a/Task/Averages-Arithmetic-mean/Calc/averages-arithmetic-mean.calc b/Task/Averages-Arithmetic-mean/Calc/averages-arithmetic-mean.calc
new file mode 100644
index 0000000000..ac2762584f
--- /dev/null
+++ b/Task/Averages-Arithmetic-mean/Calc/averages-arithmetic-mean.calc
@@ -0,0 +1 @@
+u M
diff --git a/Task/Averages-Arithmetic-mean/EasyLang/averages-arithmetic-mean.easy b/Task/Averages-Arithmetic-mean/EasyLang/averages-arithmetic-mean.easy
index 4e9bb83c20..3e05c7c28d 100644
--- a/Task/Averages-Arithmetic-mean/EasyLang/averages-arithmetic-mean.easy
+++ b/Task/Averages-Arithmetic-mean/EasyLang/averages-arithmetic-mean.easy
@@ -1,6 +1,5 @@
-func mean &f[] .
- for i = 1 to len f[] : s += f[i]
+func mean f[] .
+ for v in f[] : s += v
return s / len f[]
.
-f[] = [ 1 2 3 4 5 6 7 8 ]
-print mean f[]
+print mean [ 1 2 3 4 5 6 7 8 ]
diff --git a/Task/Averages-Arithmetic-mean/Emacs-Lisp/averages-arithmetic-mean-1.el b/Task/Averages-Arithmetic-mean/Emacs-Lisp/averages-arithmetic-mean-1.el
new file mode 100644
index 0000000000..10499d020b
--- /dev/null
+++ b/Task/Averages-Arithmetic-mean/Emacs-Lisp/averages-arithmetic-mean-1.el
@@ -0,0 +1,3 @@
+(defun mean (lst)
+ (/ (float (apply '+ lst)) (length lst)))
+(mean '(1 2 3 4))
diff --git a/Task/Averages-Arithmetic-mean/Emacs-Lisp/averages-arithmetic-mean-2.el b/Task/Averages-Arithmetic-mean/Emacs-Lisp/averages-arithmetic-mean-2.el
new file mode 100644
index 0000000000..05764b43ec
--- /dev/null
+++ b/Task/Averages-Arithmetic-mean/Emacs-Lisp/averages-arithmetic-mean-2.el
@@ -0,0 +1,2 @@
+(let ((x '(1 2 3 4)))
+ (calc-eval "vmean($1)" nil (append '(vec) x)))
diff --git a/Task/Averages-Arithmetic-mean/Emacs-Lisp/averages-arithmetic-mean-3.el b/Task/Averages-Arithmetic-mean/Emacs-Lisp/averages-arithmetic-mean-3.el
new file mode 100644
index 0000000000..9a674c11de
--- /dev/null
+++ b/Task/Averages-Arithmetic-mean/Emacs-Lisp/averages-arithmetic-mean-3.el
@@ -0,0 +1,4 @@
+(let ((x '(1 2 3 4)))
+ (string-to-number
+ (math-format-value
+ (calcFunc-vmean (cons 'vec x)))))
diff --git a/Task/Averages-Arithmetic-mean/Euphoria/averages-arithmetic-mean.eu b/Task/Averages-Arithmetic-mean/Euphoria/averages-arithmetic-mean.eu
new file mode 100644
index 0000000000..80058ad511
--- /dev/null
+++ b/Task/Averages-Arithmetic-mean/Euphoria/averages-arithmetic-mean.eu
@@ -0,0 +1,16 @@
+function mean(sequence s)
+ atom sum
+ if length(s) = 0 then
+ return 0
+ else
+ sum = 0
+ for i = 1 to length(s) do
+ sum += s[i]
+ end for
+ return sum/length(s)
+ end if
+end function
+
+sequence test
+test = {1.0, 2.0, 5.0, -5.0, 9.5, 3.14159}
+? mean(test)
diff --git a/Task/Averages-Arithmetic-mean/Langur/averages-arithmetic-mean.langur b/Task/Averages-Arithmetic-mean/Langur/averages-arithmetic-mean.langur
index ad6e0ac086..9b9bdda03a 100644
--- a/Task/Averages-Arithmetic-mean/Langur/averages-arithmetic-mean.langur
+++ b/Task/Averages-Arithmetic-mean/Langur/averages-arithmetic-mean.langur
@@ -1,4 +1,4 @@
-val umean = fn x:fold(x, by=fn{+}) / len(x)
+val umean = fn(x list) { fold(x, by=fn{+}) / len(x) }
writeln " custom: ", umean([7, 3, 12])
writeln "built-in: ", mean([7, 3, 12])
diff --git a/Task/Averages-Arithmetic-mean/PowerShell/averages-arithmetic-mean-1.ps1 b/Task/Averages-Arithmetic-mean/PowerShell/averages-arithmetic-mean-1.ps1
new file mode 100644
index 0000000000..17594cda09
--- /dev/null
+++ b/Task/Averages-Arithmetic-mean/PowerShell/averages-arithmetic-mean-1.ps1
@@ -0,0 +1,11 @@
+function mean ($x) {
+ if ($x.Count -eq 0) {
+ return 0
+ } else {
+ $sum = 0
+ foreach ($i in $x) {
+ $sum += $i
+ }
+ return $sum / $x.Count
+ }
+}
diff --git a/Task/Averages-Arithmetic-mean/PowerShell/averages-arithmetic-mean-2.ps1 b/Task/Averages-Arithmetic-mean/PowerShell/averages-arithmetic-mean-2.ps1
new file mode 100644
index 0000000000..5e5b533ad3
--- /dev/null
+++ b/Task/Averages-Arithmetic-mean/PowerShell/averages-arithmetic-mean-2.ps1
@@ -0,0 +1,7 @@
+function mean ($x) {
+ if ($x.Count -eq 0) {
+ return 0
+ } else {
+ return ($x | Measure-Object -Average).Average
+ }
+}
diff --git a/Task/Averages-Arithmetic-mean/REXX/averages-arithmetic-mean.rexx b/Task/Averages-Arithmetic-mean/REXX/averages-arithmetic-mean.rexx
index efa4be3b69..dfddd0144b 100644
--- a/Task/Averages-Arithmetic-mean/REXX/averages-arithmetic-mean.rexx
+++ b/Task/Averages-Arithmetic-mean/REXX/averages-arithmetic-mean.rexx
@@ -1,27 +1,29 @@
-/*REXX program finds the averages/arithmetic mean of several lists (vectors) or CL input*/
-parse arg @.1; if @.1='' then do; #=6 /*vector from the C.L.?*/
- @.1 = 10 9 8 7 6 5 4 3 2 1
- @.2 = 10 9 8 7 6 5 4 3 2 1 0 0 0 0 .11
- @.3 = '10 20 30 40 50 -100 4.7 -11e2'
- @.4 = '1 2 3 4 five 6 7 8 9 10.1. ±2'
- @.5 = 'World War I & World War II'
- @.6 = /* ◄─── a null value. */
- end
- else #=1 /*number of CL vectors.*/
- do j=1 for #
- say ' numbers = ' @.j
- say ' average = ' avg(@.j)
- say copies('═', 79)
- end /*t*/
-exit /*stick a fork in it, we're all done. */
-/*──────────────────────────────────────────────────────────────────────────────────────*/
-avg: procedure; parse arg x; #=words(x) /*#: number of items.*/
- if #==0 then return 'N/A: ───[null vector.]' /*No words? Return N/A*/
- $=0
- do k=1 for #; _=word(x,k) /*obtain a number. */
- if datatype(_,'N') then do; $=$+_; iterate; end /*if numeric, then add*/
- say left('',40) "***error*** non-numeric: " _; #=#-1 /*error; adjust number*/
- end /*k*/
+-- 21 Feb 2026
+include Setting
- if #==0 then return 'N/A: ───[no numeric values.]' /*No nums? Return N/A*/
- return $ / # /*return the average. */
+say 'ARITHMETIC MEAN'
+say version
+say
+call Task '1;2;3;4;5;6;7;8;9;10'
+call Task '1;10;100;1000;100000'
+call Task '1'
+exit
+
+Task:
+procedure
+arg xx
+say 'Arithmetic mean of' List2form(xx) '=' AmeanL(xx)
+return
+
+AmeanL:
+procedure
+arg xx
+rr=0; nn=0
+do while xx<>''
+ parse var xx xw';'xx
+ rr+=xw; nn+=1
+end
+return rr/nn
+
+-- AmeanL full version; List2form
+include Math
diff --git a/Task/Averages-Arithmetic-mean/ReScript/averages-arithmetic-mean.res b/Task/Averages-Arithmetic-mean/ReScript/averages-arithmetic-mean.res
new file mode 100644
index 0000000000..adc2db3484
--- /dev/null
+++ b/Task/Averages-Arithmetic-mean/ReScript/averages-arithmetic-mean.res
@@ -0,0 +1,7 @@
+let arr = [3, 8, 4, 1, 5, 12]
+
+let num = Js.Array.length(arr)
+let tot = Js.Array.reduce(\"+", 0, arr)
+let mean = float_of_int(tot) /. float_of_int(num)
+
+Js.log(Js.Float.toString(mean))
diff --git a/Task/Averages-Arithmetic-mean/Rebol/averages-arithmetic-mean-1.rebol b/Task/Averages-Arithmetic-mean/Rebol/averages-arithmetic-mean-1.rebol
new file mode 100644
index 0000000000..ca58cf86ef
--- /dev/null
+++ b/Task/Averages-Arithmetic-mean/Rebol/averages-arithmetic-mean-1.rebol
@@ -0,0 +1,19 @@
+rebol [
+ Title: "Arithmetic Mean (Average)"
+ URL: http://rosettacode.org/wiki/Average/Arithmetic_mean
+]
+
+average: func [v /local sum][
+ if empty? v [return 0]
+
+ sum: 0
+ forall v [sum: sum + v/1]
+ sum / length? v
+]
+
+; Note precision loss as spread increased.
+
+print [mold x: [] "->" average x]
+print [mold x: [3 1 4 1 5 9] "->" average x]
+print [mold x: [1000 3 1 4 1 5 9 -1000] "->" average x]
+print [mold x: [1e20 3 1 4 1 5 9 -1e20] "->" average x]
diff --git a/Task/Averages-Arithmetic-mean/Rebol/averages-arithmetic-mean-2.rebol b/Task/Averages-Arithmetic-mean/Rebol/averages-arithmetic-mean-2.rebol
new file mode 100644
index 0000000000..b6075652c4
--- /dev/null
+++ b/Task/Averages-Arithmetic-mean/Rebol/averages-arithmetic-mean-2.rebol
@@ -0,0 +1,4 @@
+probe vect: #(i8! [3 1 4 1 5 9])
+print ["mean:" vect/mean]
+print ""
+print query vect object! ;; to show all vector's info
diff --git a/Task/Averages-Arithmetic-mean/Uiua/averages-arithmetic-mean.uiua b/Task/Averages-Arithmetic-mean/Uiua/averages-arithmetic-mean.uiua
new file mode 100644
index 0000000000..8395a54436
--- /dev/null
+++ b/Task/Averages-Arithmetic-mean/Uiua/averages-arithmetic-mean.uiua
@@ -0,0 +1,2 @@
+Avg ← ÷⧻⟜/+
+Avg [1 2 3 4]
diff --git a/Task/Averages-Arithmetic-mean/VBScript/averages-arithmetic-mean.vbs b/Task/Averages-Arithmetic-mean/VBScript/averages-arithmetic-mean.vbs
new file mode 100644
index 0000000000..3201a0e9e1
--- /dev/null
+++ b/Task/Averages-Arithmetic-mean/VBScript/averages-arithmetic-mean.vbs
@@ -0,0 +1,11 @@
+Function mean(arr)
+ size = UBound(arr) + 1
+ mean = 0
+ For i = 0 To UBound(arr)
+ mean = mean + arr(i)
+ Next
+ mean = mean/size
+End Function
+
+'Example
+WScript.Echo mean(Array(3,1,4,1,5,9))
diff --git a/Task/Averages-Mean-angle/Ada/averages-mean-angle.adb b/Task/Averages-Mean-angle/Ada/averages-mean-angle.adb
new file mode 100644
index 0000000000..13b4bd91ed
--- /dev/null
+++ b/Task/Averages-Mean-angle/Ada/averages-mean-angle.adb
@@ -0,0 +1,34 @@
+with Ada.Text_IO, Ada.Numerics.Generic_Elementary_Functions;
+
+procedure Mean_Angles is
+
+ type X_Real is digits 4; -- or more digits for improved precision
+ subtype Real is X_Real range 0.0 .. 360.0; -- the range of interest
+ type Angles is array(Positive range <>) of Real;
+
+ procedure Put(R: Real) is
+ package IO is new Ada.Text_IO.Float_IO(Real);
+ begin
+ IO.Put(R, Fore => 3, Aft => 2, Exp => 0);
+ end Put;
+
+ function Mean_Angle(A: Angles) return Real is
+ Sin_Sum, Cos_Sum: X_Real := 0.0; -- X_Real since sums might exceed 360.0
+ package Math is new Ada.Numerics.Generic_Elementary_Functions(Real);
+ use Math;
+ begin
+ for I in A'Range loop
+ Sin_Sum := Sin_Sum + Sin(A(I), Cycle => 360.0);
+ Cos_Sum := Cos_Sum + Cos(A(I), Cycle => 360.0);
+ end loop;
+ return Arctan(Sin_Sum / X_Real(A'Length), Cos_Sum / X_Real(A'Length),
+ Cycle => 360.0);
+ -- may raise Ada.Numerics.Argument_Error if inputs are
+ -- numerically instable, e.g., when Cos_Sum is 0.0
+ end Mean_Angle;
+
+begin
+ Put(Mean_Angle((10.0, 20.0, 30.0))); Ada.Text_IO.New_Line; -- 20.00
+ Put(Mean_Angle((10.0, 350.0))); Ada.Text_IO.New_Line; -- 0.00
+ Put(Mean_Angle((90.0, 180.0, 270.0, 360.0))); -- Ada.Numerics.Argument_Error!
+end Mean_Angles;
diff --git a/Task/Averages-Mean-angle/Crystal/averages-mean-angle.cr b/Task/Averages-Mean-angle/Crystal/averages-mean-angle.cr
new file mode 100644
index 0000000000..6ea8a0ca43
--- /dev/null
+++ b/Task/Averages-Mean-angle/Crystal/averages-mean-angle.cr
@@ -0,0 +1,17 @@
+require "complex"
+
+def deg_to_rad (d)
+ d * Math::PI / 180
+end
+
+def rad_to_deg (r)
+ r * 180 / Math::PI
+end
+
+def mean_angle (angles)
+ rad_to_deg(angles.sum {|deg| deg_to_rad(deg).cis }.phase)
+end
+
+[[350, 10], [90, 180, 270, 360], [10, 20, 30]].each do |angles|
+ puts "The mean angle of %s is: %.2f°." % [angles, mean_angle(angles)]
+end
diff --git a/Task/Averages-Mean-angle/Euphoria/averages-mean-angle.eu b/Task/Averages-Mean-angle/Euphoria/averages-mean-angle.eu
new file mode 100644
index 0000000000..4cd862d7a7
--- /dev/null
+++ b/Task/Averages-Mean-angle/Euphoria/averages-mean-angle.eu
@@ -0,0 +1,26 @@
+include std/console.e
+include std/mathcons.e
+
+sequence AngleList = {{350,10},{90,180,270,360},{10,20,30}}
+
+function atan2(atom y, atom x)
+ return 2*arctan((sqrt(power(x,2)+power(y,2)) - x)/y)
+end function
+
+function MeanAngle(sequence angles)
+ atom x = 0, y = 0
+ integer l = length(angles)
+
+ for i = 1 to length(angles) do
+ x += cos(angles[i] * PI / 180)
+ y += sin(angles[i] * PI / 180)
+ end for
+
+ return atan2(y / l, x / l) * 180 / PI
+end function
+
+for i = 1 to length(AngleList) do
+ printf(1,"Mean Angle for set %d: %3.5f\n",{i,MeanAngle(AngleList[i])})
+end for
+
+if getc(0) then end if
diff --git a/Task/Averages-Mean-angle/Pluto/averages-mean-angle.pluto b/Task/Averages-Mean-angle/Pluto/averages-mean-angle.pluto
new file mode 100644
index 0000000000..9e228705ef
--- /dev/null
+++ b/Task/Averages-Mean-angle/Pluto/averages-mean-angle.pluto
@@ -0,0 +1,20 @@
+local fmt = require "fmt"
+
+local function mean_angle(angles)
+ local n = #angles
+ local sin_sum = 0
+ local cos_sum = 0
+ for angles as angle do
+ sin_sum += math.sin(angle * math.pi / 180.0)
+ cos_sum += math.cos(angle * math.pi / 180.0)
+ end
+ return math.atan(sin_sum / n, cos_sum / n) * 180.0 / math.pi
+end
+
+local angles1 = {350, 10}
+local angles2 = {90, 180, 270, 360}
+local angles3 = {10, 20, 30}
+
+for i, angles in {angles1, angles2, angles3} do
+ fmt.print("Mean for angles %d is : %6.2f", i, mean_angle(angles))
+end
diff --git a/Task/Averages-Mean-angle/PowerShell/averages-mean-angle-1.ps1 b/Task/Averages-Mean-angle/PowerShell/averages-mean-angle-1.ps1
new file mode 100644
index 0000000000..85708d1e36
--- /dev/null
+++ b/Task/Averages-Mean-angle/PowerShell/averages-mean-angle-1.ps1
@@ -0,0 +1,7 @@
+function Get-MeanAngle ([double[]]$Angles)
+{
+ $x = ($Angles | ForEach-Object {[Math]::Cos($_ * [Math]::PI / 180)} | Measure-Object -Average).Average
+ $y = ($Angles | ForEach-Object {[Math]::Sin($_ * [Math]::PI / 180)} | Measure-Object -Average).Average
+
+ [Math]::Atan2($y, $x) * 180 / [Math]::PI
+}
diff --git a/Task/Averages-Mean-angle/PowerShell/averages-mean-angle-2.ps1 b/Task/Averages-Mean-angle/PowerShell/averages-mean-angle-2.ps1
new file mode 100644
index 0000000000..10d8e76fc9
--- /dev/null
+++ b/Task/Averages-Mean-angle/PowerShell/averages-mean-angle-2.ps1
@@ -0,0 +1 @@
+@(350, 10), @(90, 180, 270, 360), @(10, 20, 30) | ForEach-Object {Get-MeanAngle $_}
diff --git a/Task/Averages-Mean-angle/REXX/averages-mean-angle.rexx b/Task/Averages-Mean-angle/REXX/averages-mean-angle.rexx
index 02deb03dad..ad33aa359e 100644
--- a/Task/Averages-Mean-angle/REXX/averages-mean-angle.rexx
+++ b/Task/Averages-Mean-angle/REXX/averages-mean-angle.rexx
@@ -1,55 +1,39 @@
-/*REXX program computes the mean angle for a group of angles (expressed in degrees). */
-call pi /*define the value of pi to some accuracy.*/
-numeric digits length(pi) - 1; /*use PI width decimal digits of precision,*/
- showDig= 10 /*only display ten decimal digits. */
-#= 350 10 ; say show(#, meanAngleD(#)) /*display mean angle (in degrees), 1st case.*/
-#= 90 180 270 360 ; say show(#, meanAngleD(#)) /* " " " " " 2nd " */
-#= 10 20 30 ; say show(#, meanAngleD(#)) /* " " " " " 3rd " */
-exit /*stick a fork in it, we're all done with it*/
-/*───────────────────────────────────────────────────────────────────────────────────────────*/
-.sinCos: arg z,_,i; x=x*x; do k=2 by 2 until p=z; p=z; _=-_*x/(k*(k+i)); z=z+_; end; return z
-$fuzz: return min(arg(1), max(1, digits() - arg(2) ) )
-Acos: procedure; parse arg x; return pi() * .5 - Asin(x)
-Atan: parse arg x; if abs(x)=1 then return pi()*.25 * sign(x); return Asin(x/sqrt(1 + x*x))
-d2d: return arg(1) // 360
-d2r: return r2r(d2d(arg(1)) / 180 * pi() )
-r2d: return d2d((r2r(arg(1)) / pi()) * 180)
-r2r: return arg(1) // (pi() * 2)
-pi: pi=3.1415926535897932384626433832795028841971693993751058209749445923078164062862;return pi
-/*───────────────────────────────────────────────────────────────────────────────────────────*/
-Asin: procedure; parse arg x 1 z 1 o 1 p; a= abs(x); aa= a * a
- if a>1 then call AsinErr x /*argument X is out of range.*/
- if a >= sqrt(2) * .5 then return sign(x) * acos( sqrt(1 - aa), '-ASIN')
- do j=2 by 2 until p=z; p= z; o= o * aa * (j-1) / j; z= z +o / (j+1); end
- return z /* [↑] compute until no noise*/
-/*───────────────────────────────────────────────────────────────────────────────────────────*/
-Atan2: procedure; parse arg y,x; call pi; s= sign(y)
- select
- when x=0 then z= s * pi * .5
- when x<0 then if y=0 then z= pi; else z= s * (pi - abs( Atan(y/x) ) )
- otherwise z= s * Atan(y / x)
- end /*select*/; return z
-/*───────────────────────────────────────────────────────────────────────────────────────────*/
-cos: procedure; parse arg x; x= r2r(x); numeric fuzz $fuzz(6, 3)
- a= abs(x); if a=0 then return 1; if a=pi then return -1
- if a=pi*.5 | a= pi*1.5 then return 0; if a=pi/3 then return .5
- if a= pi*2/3 then return -.5; return .sinCos(1, 1, -1)
-/*───────────────────────────────────────────────────────────────────────────────────────────*/
-meanAngleD: procedure; parse arg x; numeric digits digits() + digits() % 4
- n= words(x); _sin= 0; _cos= 0
- do j=1 for n; != d2r( word(x, j)); _sin= _sin + sin(!); _cos= _cos + cos(!)
- end /*j*/
- return r2d( Atan2( _sin/n, _cos/n) )
-/*───────────────────────────────────────────────────────────────────────────────────────────*/
-show: parse arg a,mA; _= format(ma, , showDig, 0) / 1
- return left('angles='a, 30) "mean angle=" right(_, max(4, length(_) ) )
-/*───────────────────────────────────────────────────────────────────────────────────────────*/
-sin: procedure; parse arg x; x= r2r(x); numeric fuzz $fuzz(5, 3)
- if x=pi * .5 then return 1; if x==pi * 1.5 then return -1
- if abs(x)=pi | x=0 then return 0; return .sinCos(x, x, +1)
-/*───────────────────────────────────────────────────────────────────────────────────────────*/
-sqrt: procedure; parse arg x; if x=0 then return 0; d=digits(); m.=9; numeric form; h= d+6
- numeric digits; parse value format(x,2,1,,0) 'E0' with g "E" _ .; g= g * .5'e'_ % 2
- do j=0 while h>9; m.j= h; h= h % 2 + 1; end /*j*/
- do k=j+5 to 0 by -1; numeric digits m.k; g= (g + x/g) * .5; end /*k*/
- return g
+-- 21 Feb 2026
+include Setting
+
+say 'MEAN ANGLE'
+say version
+say
+numeric digits 11
+say 'Meaningful...'
+call Task '350;10'
+call Task '10;20;30'
+call Task '180'
+say
+say 'Mathematically undefined...'
+call Task '90;180;270;360'
+call Task '0;180'
+call Task '45;225'
+call Task '90;270'
+call Task '135;305'
+exit
+
+Task:
+procedure expose Memo.
+arg xx
+say 'Mean angle of list {'xx'} =' DegL(CmeanL(RadL(xx)))/1
+return
+
+CmeanL:
+-- Returns circular mean of a list
+procedure expose Memo.
+arg xx
+ss=0; sc=0
+do while xx<>''
+ parse var xx xw';'xx
+ ss+=Sin(xw); sc+=Cos(xw)
+end
+return Arctan2(sc,ss)
+
+-- CmeanL (full); DegL; RadL; Sin; Cos; Arctan2
+include Math
diff --git a/Task/Averages-Mean-angle/Scheme/averages-mean-angle-1.scm b/Task/Averages-Mean-angle/Scheme/averages-mean-angle-1.scm
new file mode 100644
index 0000000000..87cc164852
--- /dev/null
+++ b/Task/Averages-Mean-angle/Scheme/averages-mean-angle-1.scm
@@ -0,0 +1,23 @@
+(import (srfi 1 lists)) ;; use 'fold' from library
+
+(define (average l)
+ (/ (fold + 0 l) (length l)))
+
+(define pi 3.14159265358979323846264338327950288419716939937510582097)
+
+(define (radians a)
+ (* pi 1/180 a))
+
+(define (degrees a)
+ (* 180 (/ 1 pi) a))
+
+(define (mean-angle angles)
+ (let* ((angles (map radians angles))
+ (cosines (map cos angles))
+ (sines (map sin angles)))
+ (degrees (atan (average sines) (average cosines)))))
+
+(for-each (lambda (angles)
+ (display "The mean angle of ") (display angles)
+ (display " is ") (display (mean-angle angles)) (newline))
+ '((350 10) (90 180 270 360) (10 20 30)))
diff --git a/Task/Averages-Mean-angle/Scheme/averages-mean-angle-2.scm b/Task/Averages-Mean-angle/Scheme/averages-mean-angle-2.scm
new file mode 100644
index 0000000000..4e39400575
--- /dev/null
+++ b/Task/Averages-Mean-angle/Scheme/averages-mean-angle-2.scm
@@ -0,0 +1,24 @@
+(define pi (* 4 (atan 1)))
+
+(define (->radians d) (* d (/ pi 180)))
+(define (->degrees r) (* r (/ 180 pi)))
+
+(define (average-direction angles)
+ (->degrees
+ ;; find the angle of the sum in radians
+ (angle
+ (apply + (map (lambda (d)
+ ;; a complex number on the unit circle
+ (make-polar 1 (->radians d)))
+ angles)))))
+
+(for-each (lambda (l)
+ (for-each display
+ (list "The mean angle of "
+ l
+ " is "
+ (average-direction l)
+ #\newline)))
+ '((350 10)
+ (90 180 270 360)
+ (10 20 30)))
diff --git a/Task/Averages-Mean-time-of-day/Ada/averages-mean-time-of-day.adb b/Task/Averages-Mean-time-of-day/Ada/averages-mean-time-of-day.adb
new file mode 100644
index 0000000000..368e425a78
--- /dev/null
+++ b/Task/Averages-Mean-time-of-day/Ada/averages-mean-time-of-day.adb
@@ -0,0 +1,79 @@
+with Ada.Calendar.Formatting;
+with Ada.Command_Line;
+with Ada.Numerics.Elementary_Functions;
+with Ada.Strings.Fixed;
+with Ada.Text_IO;
+
+procedure Mean_Time_Of_Day is
+
+ subtype Time is Ada.Calendar.Time;
+ subtype Time_Of_Day is Ada.Calendar.Day_Duration;
+ subtype Time_String is String (1 .. 8); -- "HH:MM:SS"
+
+ type Time_List is array (Positive range <>) of Time_String;
+
+ function Average_Time (List : Time_List) return Time_String is
+
+ function To_Time (Time_Image : Time_String) return Time
+ is (Ada.Calendar.Formatting.Value ("2000-01-01 " & Time_Image));
+
+ function To_Time_Of_Day (TS : Time) return Time_Of_Day is
+ use Ada.Calendar.Formatting;
+ Hour_Part : constant Time_Of_Day := 60.0 * 60.0 * Hour (TS);
+ Min_Part : constant Time_Of_Day := 60.0 * Minute (TS);
+ Sec_Part : constant Time_Of_Day := Time_Of_Day (Second (TS));
+ begin
+ return Hour_Part + Min_Part + Sec_Part;
+ end To_Time_Of_Day;
+
+ function To_Time_Image (Angle : Time_Of_Day) return Time_String
+ is
+ use Ada.Calendar.Formatting;
+ TOD : constant Time := Time_Of
+ (Year => 2000, Month => 1, Day => 1, -- Not used
+ Seconds => Angle);
+ begin
+ return Ada.Strings.Fixed.Tail (Image (TOD), Time_String'Length);
+ end To_Time_Image;
+
+ function Average_Time_Of_Day (List : Time_List) return Time_Of_Day is
+ use Ada.Numerics.Elementary_Functions;
+ Cycle : constant Float := Float (Time_Of_Day'Last);
+ X_Sum, Y_Sum : Float := 0.0;
+ Angle : Float;
+ begin
+ for Time_Stamp of List loop
+ Angle := Float (To_Time_Of_Day (To_Time (Time_Stamp)));
+ X_Sum := X_Sum + Cos (Angle, Cycle => Cycle);
+ Y_Sum := Y_Sum + Sin (Angle, Cycle => Cycle);
+ end loop;
+ Angle := Arctan (Y_Sum, X_Sum, Cycle => Cycle);
+ if Angle < 0.0 then
+ Angle := Angle + Cycle;
+ elsif Angle > Cycle then
+ Angle := Angle - Cycle;
+ end if;
+ return Time_Of_Day (Angle);
+ end Average_Time_Of_Day;
+
+ begin
+ return To_Time_Image (Average_Time_Of_Day (List));
+ end Average_Time;
+
+ use Ada.Command_Line;
+ List : Time_List (1 .. Argument_Count);
+begin
+ if Argument_Count = 0 then
+ raise Constraint_Error;
+ end if;
+
+ for A in 1 .. Argument_Count loop
+ List (A) := Argument (A);
+ end loop;
+ Ada.Text_IO.Put_Line (Average_Time (List));
+
+exception
+ when others =>
+ Ada.Text_IO.Put_Line ("Usage: mean_time_of_day ...");
+ Ada.Text_IO.Put_Line (" ... 'HH:MM:SS' format");
+end Mean_Time_Of_Day;
diff --git a/Task/Averages-Mean-time-of-day/Crystal/averages-mean-time-of-day.cr b/Task/Averages-Mean-time-of-day/Crystal/averages-mean-time-of-day.cr
new file mode 100644
index 0000000000..586ce7a1f4
--- /dev/null
+++ b/Task/Averages-Mean-time-of-day/Crystal/averages-mean-time-of-day.cr
@@ -0,0 +1,39 @@
+require "complex"
+
+def sec_to_rad (d)
+ (d - 43200) * Math::PI / 43200
+end
+
+def rad_to_sec (r)
+ r * 43200 / Math::PI + 43200
+end
+
+def time_to_sec (t)
+ if t =~ /^(\d\d):(\d\d):(\d\d)$/
+ $1.to_i * 3600 + $2.to_i * 60 + $3.to_i
+ else
+ raise "invalid time format"
+ end
+end
+
+def sec_to_time (s)
+ h, s = s.divmod(3600)
+ m, s = s.divmod(60)
+ "%02d:%02d:%02d" % {h, m, s.round.to_i}
+end
+
+def rad_to_time (r)
+ sec_to_time(rad_to_sec(r))
+end
+
+def time_to_rad (t)
+ sec_to_rad(time_to_sec(t))
+end
+
+def mean_time (times)
+ rad_to_time(times.sum {|time| time_to_rad(time).cis }.phase)
+end
+
+[["23:00:17", "23:40:20", "00:12:45", "00:17:19"]].each do |times|
+ puts "The mean time of (%s) is: %s." % [times.join(" "), mean_time(times)]
+ end
diff --git a/Task/Averages-Mean-time-of-day/Euphoria/averages-mean-time-of-day.eu b/Task/Averages-Mean-time-of-day/Euphoria/averages-mean-time-of-day.eu
new file mode 100644
index 0000000000..243f11d54f
--- /dev/null
+++ b/Task/Averages-Mean-time-of-day/Euphoria/averages-mean-time-of-day.eu
@@ -0,0 +1,63 @@
+include std/console.e
+include std/math.e
+include std/mathcons.e
+include std/sequence.e
+include std/get.e
+
+function T2D(sequence TimeSeq)
+ return (360 * TimeSeq[1] / 24 + 360 * TimeSeq[2] / (24 * 60) +
+ 360 * TimeSeq[3] / (24 * 3600))
+end function
+
+function D2T(atom angle)
+ sequence TimeSeq = {0,0,0}
+ atom seconds = 24 * 60 * 60 * angle / 360
+
+ TimeSeq[3] = mod(seconds,60)
+ TimeSeq[2] = (mod(seconds,3600) - TimeSeq[3]) / 60
+ TimeSeq[1] = seconds / 3600
+
+ return TimeSeq
+end function
+
+function MeanAngle(sequence angles)
+ atom x = 0, y = 0
+ integer l = length(angles)
+
+ for i = 1 to length(angles) do
+ x += cos(angles[i] * PI / 180)
+ y += sin(angles[i] * PI / 180)
+ end for
+
+ return atan2(y / l, x / l) * 180 / PI
+end function
+
+sequence TimeEntry, TimeList = {}, TimeSeq
+
+puts(1,"Enter times. Enter with no input to end\n")
+while 1 do
+ TimeEntry = prompt_string("")
+ if equal(TimeEntry,"") then -- no more entries
+ for i = 1 to length(TimeList) do
+ TimeList[i] = split(TimeList[i],":") -- split the times into sequences
+ for j = 1 to 3 do
+ TimeList[i][j] = defaulted_value(TimeList[i][j],0) -- convert to numerical values
+ end for
+ end for
+ exit
+ end if
+ TimeList = append(TimeList,TimeEntry)
+end while
+
+sequence AngleList = repeat({},length(TimeList))
+
+for i = 1 to length(AngleList) do
+ AngleList[i] = T2D(TimeList[i])
+end for
+
+sequence MeanTime = D2T(360+MeanAngle(AngleList))
+
+printf(1,"\nMean Time: %d:%d:%d\n",MeanTime)
+
+
+if getc(0) then end if
diff --git a/Task/Averages-Mean-time-of-day/Pluto/averages-mean-time-of-day.pluto b/Task/Averages-Mean-time-of-day/Pluto/averages-mean-time-of-day.pluto
new file mode 100644
index 0000000000..aa6e073aec
--- /dev/null
+++ b/Task/Averages-Mean-time-of-day/Pluto/averages-mean-time-of-day.pluto
@@ -0,0 +1,32 @@
+local function time_to_degs(time)
+ local t = time:split(":")
+ local h = tonumber(t[1]) * 3600
+ local m = tonumber(t[2]) * 60
+ local s = tonumber(t[3])
+ return (h + m + s) / 240
+end
+
+local function degs_to_time(d)
+ while d < 0 do d += 360 end
+ local s = math.round(d * 240)
+ local h = s // 3600
+ local m = s % 3600
+ s = m % 60
+ m //= 60
+ return string.format("%2d:%2d:%2d", h, m, s)
+end
+
+local function mean_angle(angles)
+ local n = #angles
+ local sin_sum = 0
+ local cos_sum = 0
+ for angles as angle do
+ sin_sum += math.sin(angle * math.pi / 180)
+ cos_sum += math.cos(angle * math.pi / 180)
+ end
+ return math.atan(sin_sum / n, cos_sum / n) * 180 / math.pi
+end
+
+local times = {"23:00:17", "23:40:20", "00:12:45", "00:17:19"}
+local angles = times:mapped(|t| -> time_to_degs(t))
+print($"Mean time of day is : {degs_to_time(mean_angle(angles))}")
diff --git a/Task/Averages-Mean-time-of-day/PowerShell/averages-mean-time-of-day-1.ps1 b/Task/Averages-Mean-time-of-day/PowerShell/averages-mean-time-of-day-1.ps1
new file mode 100644
index 0000000000..778a83e523
--- /dev/null
+++ b/Task/Averages-Mean-time-of-day/PowerShell/averages-mean-time-of-day-1.ps1
@@ -0,0 +1,66 @@
+function Get-MeanTimeOfDay
+{
+ [CmdletBinding()]
+ [OutputType([timespan])]
+ Param
+ (
+ [Parameter(Mandatory=$true,
+ ValueFromPipeline=$true,
+ ValueFromPipelineByPropertyName=$true)]
+ [ValidatePattern("(?:2[0-3]|[01]?[0-9])[:.][0-5]?[0-9][:.][0-5]?[0-9]")]
+ [string[]]
+ $Time
+ )
+
+ Begin
+ {
+ [double[]]$angles = @()
+
+ function ConvertFrom-Time ([timespan]$Time)
+ {
+ [double]((360 * $Time.Hours / 24) + (360 * $Time.Minutes / (24 * 60)) + (360 * $Time.Seconds / (24 * 3600)))
+ }
+
+ function ConvertTo-Time ([double]$Angle)
+ {
+ $t = New-TimeSpan -Hours ([int](24 * 60 * 60 * $Angle / 360) / 3600) `
+ -Minutes (([int](24 * 60 * 60 * $Angle / 360) % 3600 - [int](24 * 60 * 60 * $Angle / 360) % 60) / 60) `
+ -Seconds ([int]((24 * 60 * 60 * $Angle / 360) % 60))
+
+ if ($t.Days -gt 0)
+ {
+ return ($t - (New-TimeSpan -Hours 1))
+ }
+
+ $t
+ }
+
+ function Get-MeanAngle ([double[]]$Angles)
+ {
+ [double]$x,$y = 0
+
+ for ($i = 0; $i -lt $Angles.Count; $i++)
+ {
+ $x += [Math]::Cos($Angles[$i] * [Math]::PI / 180)
+ $y += [Math]::Sin($Angles[$i] * [Math]::PI / 180)
+ }
+
+ $result = [Math]::Atan2(($y / $Angles.Count), ($x / $Angles.Count)) * 180 / [Math]::PI
+
+ if ($result -lt 0)
+ {
+ return ($result + 360)
+ }
+
+ $result
+ }
+ }
+ Process
+ {
+ $angles += ConvertFrom-Time $_
+ }
+ End
+ {
+ ConvertTo-Time (Get-MeanAngle $angles)
+ }
+}
diff --git a/Task/Averages-Mean-time-of-day/PowerShell/averages-mean-time-of-day-2.ps1 b/Task/Averages-Mean-time-of-day/PowerShell/averages-mean-time-of-day-2.ps1
new file mode 100644
index 0000000000..450ffa6166
--- /dev/null
+++ b/Task/Averages-Mean-time-of-day/PowerShell/averages-mean-time-of-day-2.ps1
@@ -0,0 +1,2 @@
+[timespan]$meanTimeOfDay = "23:00:17","23:40:20","00:12:45","00:17:19" | Get-MeanTimeOfDay
+"Mean time is {0}" -f (Get-Date $meanTimeOfDay.ToString()).ToString("hh:mm:ss tt")
diff --git a/Task/Averages-Mean-time-of-day/Uiua/averages-mean-time-of-day.uiua b/Task/Averages-Mean-time-of-day/Uiua/averages-mean-time-of-day.uiua
index 291cc80510..314db64b4d 100644
--- a/Task/Averages-Mean-time-of-day/Uiua/averages-mean-time-of-day.uiua
+++ b/Task/Averages-Mean-time-of-day/Uiua/averages-mean-time-of-day.uiua
@@ -16,9 +16,3 @@ Ts ← "23:00:17, 23:40:20, 00:12:45, 00:17:19"
⊜(PtoC ⊟1 ×RpS ParseTS)¬⦷", ".Ts # Get TSs as unit complex numbers.
⁅÷RpS⊡1°PtoC÷⊃(⧻|/+) # Average them and convert back to seconds.
°ParseTS+×SpD<0. # Ensure its >0, format as TS.
-
-
-"23:47:43" -diff --git a/Task/Averages-Median/Ada/averages-median.adb b/Task/Averages-Median/Ada/averages-median.adb new file mode 100644 index 0000000000..8d85b80a30 --- /dev/null +++ b/Task/Averages-Median/Ada/averages-median.adb @@ -0,0 +1,31 @@ +with Ada.Text_IO, Ada.Float_Text_IO; + +procedure FindMedian is + + f: array(1..10) of float := ( 4.4, 2.3, -1.7, 7.5, 6.6, 0.0, 1.9, 8.2, 9.3, 4.5 ); + min_idx: integer; + min_val, median_val, swap: float; + +begin + for i in f'range loop + min_idx := i; + min_val := f(i); + for j in i+1 .. f'last loop + if f(j) < min_val then + min_idx := j; + min_val := f(j); + end if; + end loop; + swap := f(i); f(i) := f(min_idx); f(min_idx) := swap; + end loop; + + if f'length mod 2 /= 0 then + median_val := f( f'length/2+1 ); + else + median_val := ( f(f'length/2) + f(f'length/2+1) ) / 2.0; + end if; + + Ada.Text_IO.Put( "Median value: " ); + Ada.Float_Text_IO.Put( median_val ); + Ada.Text_IO.New_line; +end FindMedian; diff --git a/Task/Averages-Median/COBOL/averages-median.cob b/Task/Averages-Median/COBOL/averages-median.cob new file mode 100644 index 0000000000..bac369fdfa --- /dev/null +++ b/Task/Averages-Median/COBOL/averages-median.cob @@ -0,0 +1 @@ +FUNCTION MEDIAN(some-table (ALL)) diff --git a/Task/Averages-Median/Euphoria/averages-median.eu b/Task/Averages-Median/Euphoria/averages-median.eu new file mode 100644 index 0000000000..79839c9c20 --- /dev/null +++ b/Task/Averages-Median/Euphoria/averages-median.eu @@ -0,0 +1,25 @@ +function median(sequence s) + atom min,k + -- Selection sort of half+1 + for i = 1 to length(s)/2+1 do + min = s[i] + k = 0 + for j = i+1 to length(s) do + if s[j] < min then + min = s[j] + k = j + end if + end for + if k then + s[k] = s[i] + s[i] = min + end if + end for + if remainder(length(s),2) = 0 then + return (s[$/2]+s[$/2+1])/2 + else + return s[$/2+1] + end if +end function + +? median({ 4.4, 2.3, -1.7, 7.5, 6.6, 0.0, 1.9, 8.2, 9.3, 4.5 }) diff --git a/Task/Averages-Median/PowerShell/averages-median-1.ps1 b/Task/Averages-Median/PowerShell/averages-median-1.ps1 new file mode 100644 index 0000000000..10f1443537 --- /dev/null +++ b/Task/Averages-Median/PowerShell/averages-median-1.ps1 @@ -0,0 +1,69 @@ +function Measure-Data +{ + [CmdletBinding()] + [OutputType([PSCustomObject])] + Param + ( + [Parameter(Mandatory=$true, + Position=0)] + [double[]] + $Data + ) + + Begin + { + function Get-Mode ([double[]]$Data) + { + if ($Data.Count -gt ($Data | Select-Object -Unique).Count) + { + $groups = $Data | Group-Object | Sort-Object -Property Count -Descending + + return ($groups | Where-Object {[double]$_.Count -eq [double]$groups[0].Count}).Name | ForEach-Object {[double]$_} + } + else + { + return $null + } + } + + function Get-StandardDeviation ([double[]]$Data) + { + $variance = 0 + $average = $Data | Measure-Object -Average | Select-Object -Property Count, Average + + foreach ($number in $Data) + { + $variance += [Math]::Pow(($number - $average.Average),2) + } + + return [Math]::Sqrt($variance / ($average.Count-1)) + } + + function Get-Median ([double[]]$Data) + { + if ($Data.Count % 2) + { + return $Data[[Math]::Floor($Data.Count/2)] + } + else + { + return ($Data[$Data.Count/2], $Data[$Data.Count/2-1] | Measure-Object -Average).Average + } + } + } + Process + { + $Data = $Data | Sort-Object + + $Data | Measure-Object -Maximum -Minimum -Sum -Average | + Select-Object -Property Count, + Sum, + Minimum, + Maximum, + @{Name='Range'; Expression={$_.Maximum - $_.Minimum}}, + @{Name='Mean' ; Expression={$_.Average}} | + Add-Member -MemberType NoteProperty -Name Median -Value (Get-Median $Data) -PassThru | + Add-Member -MemberType NoteProperty -Name StandardDeviation -Value (Get-StandardDeviation $Data) -PassThru | + Add-Member -MemberType NoteProperty -Name Mode -Value (Get-Mode $Data) -PassThru + } +} diff --git a/Task/Averages-Median/PowerShell/averages-median-2.ps1 b/Task/Averages-Median/PowerShell/averages-median-2.ps1 new file mode 100644 index 0000000000..96c1411d1a --- /dev/null +++ b/Task/Averages-Median/PowerShell/averages-median-2.ps1 @@ -0,0 +1,2 @@ +$statistics = Measure-Data 4, 5, 6, 7, 7, 7, 8, 1, 1, 1, 2, 3 +$statistics diff --git a/Task/Averages-Median/PowerShell/averages-median-3.ps1 b/Task/Averages-Median/PowerShell/averages-median-3.ps1 new file mode 100644 index 0000000000..2157fc0087 --- /dev/null +++ b/Task/Averages-Median/PowerShell/averages-median-3.ps1 @@ -0,0 +1 @@ +$statistics.Median diff --git a/Task/Averages-Median/ReScript/averages-median.res b/Task/Averages-Median/ReScript/averages-median.res new file mode 100644 index 0000000000..7d073928ea --- /dev/null +++ b/Task/Averages-Median/ReScript/averages-median.res @@ -0,0 +1,24 @@ +let median = (arr) => +{ + let float_compare = (a, b) => { + let diff = a -. b + if diff == 0.0 { 0 } else + if diff > 0.0 { 1 } else { -1 } + } + let _ = Js.Array2.sortInPlaceWith(arr, float_compare) + let count = Js.Array.length(arr) + // find the middle value, or the lowest middle value + let middleval = ((count - 1) / 2) + let median = + if (mod(count, 2) != 0) { // odd number, middle is the median + arr[middleval] + } else { // even number, calculate avg of 2 medians + let low = arr[middleval] + let high = arr[middleval+1] + ((low +. high) /. 2.0) + } + median +} + +Js.log(median([4.1, 5.6, 7.2, 1.7, 9.3, 4.4, 3.2])) +Js.log(median([4.1, 7.2, 1.7, 9.3, 4.4, 3.2])) diff --git a/Task/Averages-Median/Rebol/averages-median-1.rebol b/Task/Averages-Median/Rebol/averages-median-1.rebol new file mode 100644 index 0000000000..3b059ddcdc --- /dev/null +++ b/Task/Averages-Median/Rebol/averages-median-1.rebol @@ -0,0 +1,15 @@ +median: func [ + "Returns the midpoint value in a series of numbers; half the values are above, half are below." + block [any-block!] + /local len mid +][ + if empty? block [return none] + block: sort copy block + len: length? block + mid: to integer! len / 2 + either odd? len [ + pick block add 1 mid + ][ + (block/:mid) + (pick block add 1 mid) / 2 + ] +] diff --git a/Task/Averages-Median/Rebol/averages-median-2.rebol b/Task/Averages-Median/Rebol/averages-median-2.rebol new file mode 100644 index 0000000000..e16f4890cd --- /dev/null +++ b/Task/Averages-Median/Rebol/averages-median-2.rebol @@ -0,0 +1,5 @@ +vect: #(i8! [3 1 4 1 5 9]) +vect/median +;== 3.5 +query vect 'median +;== 3.5 diff --git a/Task/Averages-Median/Uiua/averages-median.uiua b/Task/Averages-Median/Uiua/averages-median.uiua new file mode 100644 index 0000000000..b97c295022 --- /dev/null +++ b/Task/Averages-Median/Uiua/averages-median.uiua @@ -0,0 +1,4 @@ +Median ← ÷2/+⊏[∩(⌊÷2)⊸-₁]⊸⧻⍆ + +Median [4.1 5.6 7.2 1.7 9.3 4.4 3.2] +Median [4.1 7.2 1.7 9.3 4.4 3.2] diff --git a/Task/Averages-Mode/Ada/averages-mode-1.adb b/Task/Averages-Mode/Ada/averages-mode-1.adb new file mode 100644 index 0000000000..0757dcc331 --- /dev/null +++ b/Task/Averages-Mode/Ada/averages-mode-1.adb @@ -0,0 +1,8 @@ +generic + type Element_Type is private; + type Element_Array is array (Positive range <>) of Element_Type; +package Mode is + + function Get_Mode (Set : Element_Array) return Element_Array; + +end Mode; diff --git a/Task/Averages-Mode/Ada/averages-mode-2.adb b/Task/Averages-Mode/Ada/averages-mode-2.adb new file mode 100644 index 0000000000..08dee1b804 --- /dev/null +++ b/Task/Averages-Mode/Ada/averages-mode-2.adb @@ -0,0 +1,102 @@ +with Ada.Containers.Indefinite_Vectors; + +package body Mode is + + -- map Count to Elements + package Count_Vectors is new Ada.Containers.Indefinite_Vectors + (Element_Type => Element_Array, + Index_Type => Positive); + + procedure Add (To : in out Count_Vectors.Vector; Item : Element_Type) is + use type Count_Vectors.Cursor; + Position : Count_Vectors.Cursor := To.First; + Found : Boolean := False; + begin + while not Found and then Position /= Count_Vectors.No_Element loop + declare + Elements : Element_Array := Count_Vectors.Element (Position); + begin + for I in Elements'Range loop + if Elements (I) = Item then + Found := True; + end if; + end loop; + end; + if not Found then + Position := Count_Vectors.Next (Position); + end if; + end loop; + if Position /= Count_Vectors.No_Element then + -- element found, remove it and insert to next count + declare + New_Position : Count_Vectors.Cursor := + Count_Vectors.Next (Position); + begin + -- remove from old position + declare + Old_Elements : Element_Array := + Count_Vectors.Element (Position); + New_Elements : Element_Array (1 .. Old_Elements'Length - 1); + New_Index : Positive := New_Elements'First; + begin + for I in Old_Elements'Range loop + if Old_Elements (I) /= Item then + New_Elements (New_Index) := Old_Elements (I); + New_Index := New_Index + 1; + end if; + end loop; + To.Replace_Element (Position, New_Elements); + end; + -- new position not already there? + if New_Position = Count_Vectors.No_Element then + declare + New_Array : Element_Array (1 .. 1) := (1 => Item); + begin + To.Append (New_Array); + end; + else + -- add to new position + declare + Old_Elements : Element_Array := + Count_Vectors.Element (New_Position); + New_Elements : Element_Array (1 .. Old_Elements'Length + 1); + begin + New_Elements (1 .. Old_Elements'Length) := Old_Elements; + New_Elements (New_Elements'Last) := Item; + To.Replace_Element (New_Position, New_Elements); + end; + end if; + end; + else + -- element not found, add to count 1 + Position := To.First; + if Position = Count_Vectors.No_Element then + declare + New_Array : Element_Array (1 .. 1) := (1 => Item); + begin + To.Append (New_Array); + end; + else + declare + Old_Elements : Element_Array := + Count_Vectors.Element (Position); + New_Elements : Element_Array (1 .. Old_Elements'Length + 1); + begin + New_Elements (1 .. Old_Elements'Length) := Old_Elements; + New_Elements (New_Elements'Last) := Item; + To.Replace_Element (Position, New_Elements); + end; + end if; + end if; + end Add; + + function Get_Mode (Set : Element_Array) return Element_Array is + Counts : Count_Vectors.Vector; + begin + for I in Set'Range loop + Add (Counts, Set (I)); + end loop; + return Counts.Last_Element; + end Get_Mode; + +end Mode; diff --git a/Task/Averages-Mode/Ada/averages-mode-3.adb b/Task/Averages-Mode/Ada/averages-mode-3.adb new file mode 100644 index 0000000000..514d0078ec --- /dev/null +++ b/Task/Averages-Mode/Ada/averages-mode-3.adb @@ -0,0 +1,26 @@ +with Ada.Text_IO; +with Mode; +procedure Main is + type Int_Array is array (Positive range <>) of Integer; + package Int_Mode is new Mode (Integer, Int_Array); + + Test_1 : Int_Array := (1, 2, 3, 1, 2, 4, 2, 5, 2, 3, 3, 1, 3, 6); + Result : Int_Array := Int_Mode.Get_Mode (Test_1); +begin + Ada.Text_IO.Put ("Input: "); + for I in Test_1'Range loop + Ada.Text_IO.Put (Integer'Image (Test_1 (I))); + if I /= Test_1'Last then + Ada.Text_IO.Put (","); + end if; + end loop; + Ada.Text_IO.New_Line; + Ada.Text_IO.Put ("Result:"); + for I in Result'Range loop + Ada.Text_IO.Put (Integer'Image (Result (I))); + if I /= Result'Last then + Ada.Text_IO.Put (","); + end if; + end loop; + Ada.Text_IO.New_Line; +end Main; diff --git a/Task/Averages-Mode/Euphoria/averages-mode.eu b/Task/Averages-Mode/Euphoria/averages-mode.eu new file mode 100644 index 0000000000..7b4cfce394 --- /dev/null +++ b/Task/Averages-Mode/Euphoria/averages-mode.eu @@ -0,0 +1,39 @@ +include misc.e + +function mode(sequence s) + sequence uniques, counts, modes + integer j,max + uniques = {} + counts = {} + for i = 1 to length(s) do + j = find(s[i], uniques) + if j then + counts[j] += 1 + else + uniques = append(uniques, s[i]) + counts = append(counts, 1) + end if + end for + + max = counts[1] + for i = 2 to length(counts) do + if counts[i] > max then + max = counts[i] + end if + end for + + j = 1 + modes = {} + while j <= length(s) do + j = find_from(max, counts, j) + if j = 0 then + exit + end if + modes = append(modes, uniques[j]) + j += 1 + end while + return modes +end function + +constant s = { 1, "blue", 2, 7.5, 5, "green", "red", 5, 2, "blue", "white" } +pretty_print(1,mode(s),{3}) diff --git a/Task/Averages-Mode/Pluto/averages-mode.pluto b/Task/Averages-Mode/Pluto/averages-mode.pluto new file mode 100644 index 0000000000..bc911b3239 --- /dev/null +++ b/Task/Averages-Mode/Pluto/averages-mode.pluto @@ -0,0 +1,23 @@ +local fmt = require "fmt" + +local function mode(a) + local t = a:countvalues() + local max = t:values():max() + local res = {} + for k, v in t do + if v == max then res:insert(k) end + end + return res +end + +local tests = { + {1, 2, 5, -5, -9.5, 3.14159}, + { 1, "blue", 2, 7.5, 5, "green", "red", 5, 2, "blue", "white" }, + {1, 2, 3, 1, 2, 4, 2, 5, 2, 3, 3, 1, 3, 6}, + {.2, .7, .1, .8, .2}, + {"two", 7, 1, 8, "two", 8}, + "Hello there world":split(""), + {} +} + +for tests as test do fmt.lprint(mode(test)) end diff --git a/Task/Averages-Mode/PowerShell/averages-mode.ps1 b/Task/Averages-Mode/PowerShell/averages-mode.ps1 new file mode 100644 index 0000000000..a390910fd6 --- /dev/null +++ b/Task/Averages-Mode/PowerShell/averages-mode.ps1 @@ -0,0 +1,3 @@ +$data = @(1,1,1,2,3,4,5,5,6,7,7,7) +$groups = $data | group-object | sort-object count -Descending +$groups | ? {$_.Count -eq $groups[0].Count} diff --git a/Task/Averages-Mode/Uiua/averages-mode.uiua b/Task/Averages-Mode/Uiua/averages-mode.uiua new file mode 100644 index 0000000000..34819b895d --- /dev/null +++ b/Task/Averages-Mode/Uiua/averages-mode.uiua @@ -0,0 +1,3 @@ +Modes ← ▽=⊸/↥⊕⊃⧻⊢⊸⊛ +Modes [1 3 6 6 6 6 7 7 12 12 17] +Modes [1 1 2 4 4] diff --git a/Task/Averages-Pythagorean-means/Ada/averages-pythagorean-means-1.adb b/Task/Averages-Pythagorean-means/Ada/averages-pythagorean-means-1.adb new file mode 100644 index 0000000000..37d9a64ce3 --- /dev/null +++ b/Task/Averages-Pythagorean-means/Ada/averages-pythagorean-means-1.adb @@ -0,0 +1,6 @@ +package Pythagorean_Means is + type Set is array (Positive range <>) of Float; + function Arithmetic_Mean (Data : Set) return Float; + function Geometric_Mean (Data : Set) return Float; + function Harmonic_Mean (Data : Set) return Float; +end Pythagorean_Means; diff --git a/Task/Averages-Pythagorean-means/Ada/averages-pythagorean-means-2.adb b/Task/Averages-Pythagorean-means/Ada/averages-pythagorean-means-2.adb new file mode 100644 index 0000000000..c7aa66b7ac --- /dev/null +++ b/Task/Averages-Pythagorean-means/Ada/averages-pythagorean-means-2.adb @@ -0,0 +1,33 @@ +with Ada.Numerics.Generic_Elementary_Functions; +package body Pythagorean_Means is + package Math is new Ada.Numerics.Generic_Elementary_Functions (Float); + function "**" (Left, Right : Float) return Float renames Math."**"; + + function Arithmetic_Mean (Data : Set) return Float is + Sum : Float := 0.0; + begin + for I in Data'Range loop + Sum := Sum + Data (I); + end loop; + return Sum / Float (Data'Length); + end Arithmetic_Mean; + + function Geometric_Mean (Data : Set) return Float is + Product : Float := 1.0; + begin + for I in Data'Range loop + Product := Product * Data (I); + end loop; + return Product**(1.0/Float(Data'Length)); + end Geometric_Mean; + + function Harmonic_Mean (Data : Set) return Float is + Reciprocal_Sum : Float := 0.0; + begin + for I in Data'Range loop + Reciprocal_Sum := Reciprocal_Sum + Data (I)**(-1); + end loop; + return Float (Data'Length) / Reciprocal_Sum; + end Harmonic_Mean; + +end Pythagorean_Means; diff --git a/Task/Averages-Pythagorean-means/Ada/averages-pythagorean-means-3.adb b/Task/Averages-Pythagorean-means/Ada/averages-pythagorean-means-3.adb new file mode 100644 index 0000000000..4b4710e5b2 --- /dev/null +++ b/Task/Averages-Pythagorean-means/Ada/averages-pythagorean-means-3.adb @@ -0,0 +1,13 @@ +with Ada.Text_IO; +with Pythagorean_Means; +procedure Main is + My_Set : Pythagorean_Means.Set := (1.0, 2.0, 3.0, 4.0, 5.0, + 6.0, 7.0, 8.0, 9.0, 10.0); + Arithmetic_Mean : Float := Pythagorean_Means.Arithmetic_Mean (My_Set); + Geometric_Mean : Float := Pythagorean_Means.Geometric_Mean (My_Set); + Harmonic_Mean : Float := Pythagorean_Means.Harmonic_Mean (My_Set); +begin + Ada.Text_IO.Put_Line (Float'Image (Arithmetic_Mean) & " >= " & + Float'Image (Geometric_Mean) & " >= " & + Float'Image (Harmonic_Mean)); +end Main; diff --git a/Task/Averages-Pythagorean-means/Euphoria/averages-pythagorean-means.eu b/Task/Averages-Pythagorean-means/Euphoria/averages-pythagorean-means.eu new file mode 100644 index 0000000000..f4d6e0d812 --- /dev/null +++ b/Task/Averages-Pythagorean-means/Euphoria/averages-pythagorean-means.eu @@ -0,0 +1,52 @@ +function arithmetic_mean(sequence s) + atom sum + if length(s) = 0 then + return 0 + else + sum = 0 + for i = 1 to length(s) do + sum += s[i] + end for + return sum/length(s) + end if +end function + +function geometric_mean(sequence s) + atom p + p = 1 + for i = 1 to length(s) do + p *= s[i] + end for + return power(p,1/length(s)) +end function + +function harmonic_mean(sequence s) + atom sum + if length(s) = 0 then + return 0 + else + sum = 0 + for i = 1 to length(s) do + sum += 1/s[i] + end for + return length(s) / sum + end if +end function + +function true_or_false(atom x) + if x then + return "true" + else + return "false" + end if +end function + +constant s = {1,2,3,4,5,6,7,8,9,10} +constant arithmetic = arithmetic_mean(s), + geometric = geometric_mean(s), + harmonic = harmonic_mean(s) +printf(1,"Arithmetic: %g\n", arithmetic) +printf(1,"Geometric: %g\n", geometric) +printf(1,"Harmonic: %g\n", harmonic) +printf(1,"Arithmetic>=Geometric>=Harmonic: %s\n", + {true_or_false(arithmetic>=geometric and geometric>=harmonic)}) diff --git a/Task/Averages-Pythagorean-means/PowerShell/averages-pythagorean-means.ps1 b/Task/Averages-Pythagorean-means/PowerShell/averages-pythagorean-means.ps1 new file mode 100644 index 0000000000..bce581d667 --- /dev/null +++ b/Task/Averages-Pythagorean-means/PowerShell/averages-pythagorean-means.ps1 @@ -0,0 +1,23 @@ +$A = 0 +$LogG = 0 +$InvH = 0 + +$ii = 1..10 +foreach($i in $ii) { + # Arithmetic mean is computed directly + $A += $i / $ii.Count + # Geometric mean is computed using Logarithms + $LogG += [Math]::Log($i) / $ii.Count + # Harmonic mean is computed using its inverse + $InvH += 1 / ($i * $ii.Count) +} + +$G = [Math]::Exp($LogG) +$H = 1/$InvH + +write-host "Arithmetic mean: A = $A" +write-host "Geometric mean: G = $G" +write-host "Harmonic mean: H = $H" + +write-host "Is A >= G ? $($A -ge $G)" +write-host "Is G >= H ? $($G -ge $H)" diff --git a/Task/Averages-Pythagorean-means/SuperCollider/averages-pythagorean-means.sc b/Task/Averages-Pythagorean-means/SuperCollider/averages-pythagorean-means.sc new file mode 100644 index 0000000000..e7e5567596 --- /dev/null +++ b/Task/Averages-Pythagorean-means/SuperCollider/averages-pythagorean-means.sc @@ -0,0 +1,32 @@ +( +// Usage: ~arithmetic_mean.(x), where x is an array +// of numbers. +// +// Return the artithmetic mean of the values in x. +~arithmetic_mean = { + arg x; (x.sum)/(x.size) +}; + +// Usage: ~geometric_mean.(x), where x is an array +// of positive or null numbers. +// +// Return the geometric mean of the values in x. +~geometric_mean = { + arg x; (x.product)**(1/(x.size)) +}; + +// Usage: ~harmonic_mean.(x), where x is an array +// of non-null numbers. +// +// Return the harmonic mean of the values in x. +~harmonic_mean = { + arg x; (x.size)/((1/x).sum) +}; + +~x = Array.fill(10, {|i| i + 1}); +"Array: ".post; ~x.postln; +"----------------------------------".postln; +"Arithmetic mean:\t".post; ~arithmetic_mean.(~x).postln; +"Geometric mean:\t".post; ~geometric_mean.(~x).postln; +"Harmonic mean:\t".post; ~harmonic_mean.(~x).postln; +) diff --git a/Task/Averages-Pythagorean-means/Uiua/averages-pythagorean-means.uiua b/Task/Averages-Pythagorean-means/Uiua/averages-pythagorean-means.uiua new file mode 100644 index 0000000000..009e2498eb --- /dev/null +++ b/Task/Averages-Pythagorean-means/Uiua/averages-pythagorean-means.uiua @@ -0,0 +1,4 @@ +A ← ÷⊃⧻/+ +G ← ⁿ⊃(˜÷1⧻)/× +H ← ÷⊃(/+˜÷1)⧻ +⊃(A|G|H)+1⇡10 diff --git a/Task/Averages-Pythagorean-means/VBScript/averages-pythagorean-means.vbs b/Task/Averages-Pythagorean-means/VBScript/averages-pythagorean-means.vbs new file mode 100644 index 0000000000..e087a2174d --- /dev/null +++ b/Task/Averages-Pythagorean-means/VBScript/averages-pythagorean-means.vbs @@ -0,0 +1,27 @@ +Function arithmetic_mean(arr) + sum = 0 + For i = 0 To UBound(arr) + sum = sum + arr(i) + Next + arithmetic_mean = sum / (UBound(arr)+1) +End Function + +Function geometric_mean(arr) + product = 1 + For i = 0 To UBound(arr) + product = product * arr(i) + Next + geometric_mean = product ^ (1/(UBound(arr)+1)) +End Function + +Function harmonic_mean(arr) + sum = 0 + For i = 0 To UBound(arr) + sum = sum + (1/arr(i)) + Next + harmonic_mean = (UBound(arr)+1) / sum +End Function + +WScript.StdOut.WriteLine arithmetic_mean(Array(1,2,3,4,5,6,7,8,9,10)) +WScript.StdOut.WriteLine geometric_mean(Array(1,2,3,4,5,6,7,8,9,10)) +WScript.StdOut.WriteLine harmonic_mean(Array(1,2,3,4,5,6,7,8,9,10)) diff --git a/Task/Averages-Root-mean-square/Ada/averages-root-mean-square.adb b/Task/Averages-Root-mean-square/Ada/averages-root-mean-square.adb new file mode 100644 index 0000000000..bc446862ed --- /dev/null +++ b/Task/Averages-Root-mean-square/Ada/averages-root-mean-square.adb @@ -0,0 +1,20 @@ +with Ada.Float_Text_IO; use Ada.Float_Text_IO; +with Ada.Numerics.Elementary_Functions; +use Ada.Numerics.Elementary_Functions; +procedure calcrms is + type float_arr is array(1..10) of Float; + + function rms(nums : float_arr) return Float is + sum : Float := 0.0; + begin + for p in nums'Range loop + sum := sum + nums(p)**2; + end loop; + return sqrt(sum/Float(nums'Length)); + end rms; + + list : float_arr; +begin +list := (1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0); +put( rms(list) , Exp=>0); +end calcrms; diff --git a/Task/Averages-Root-mean-square/COBOL/averages-root-mean-square.cob b/Task/Averages-Root-mean-square/COBOL/averages-root-mean-square.cob new file mode 100644 index 0000000000..95698c0314 --- /dev/null +++ b/Task/Averages-Root-mean-square/COBOL/averages-root-mean-square.cob @@ -0,0 +1,21 @@ +IDENTIFICATION DIVISION. +PROGRAM-ID. QUADRATIC-MEAN-PROGRAM. +DATA DIVISION. +WORKING-STORAGE SECTION. +01 QUADRATIC-MEAN-VARS. + 05 N PIC 99 VALUE 0. + 05 N-SQUARED PIC 999. + 05 RUNNING-TOTAL PIC 999 VALUE 0. + 05 MEAN-OF-SQUARES PIC 99V9(16). + 05 QUADRATIC-MEAN PIC 9V9(15). +PROCEDURE DIVISION. +CONTROL-PARAGRAPH. + PERFORM MULTIPLICATION-PARAGRAPH 10 TIMES. + DIVIDE RUNNING-TOTAL BY 10 GIVING MEAN-OF-SQUARES. + COMPUTE QUADRATIC-MEAN = FUNCTION SQRT(MEAN-OF-SQUARES). + DISPLAY QUADRATIC-MEAN UPON CONSOLE. + STOP RUN. +MULTIPLICATION-PARAGRAPH. + ADD 1 TO N. + MULTIPLY N BY N GIVING N-SQUARED. + ADD N-SQUARED TO RUNNING-TOTAL. diff --git a/Task/Averages-Root-mean-square/Emacs-Lisp/averages-root-mean-square.el b/Task/Averages-Root-mean-square/Emacs-Lisp/averages-root-mean-square.el new file mode 100644 index 0000000000..c5dd34968a --- /dev/null +++ b/Task/Averages-Root-mean-square/Emacs-Lisp/averages-root-mean-square.el @@ -0,0 +1,5 @@ +(defun rms (nums) + (sqrt (/ (apply '+ (mapcar (lambda (x) (* x x)) nums)) + (float (length nums))))) + +(rms (number-sequence 1 10)) diff --git a/Task/Averages-Root-mean-square/Euphoria/averages-root-mean-square.eu b/Task/Averages-Root-mean-square/Euphoria/averages-root-mean-square.eu new file mode 100644 index 0000000000..7ad2ff66b8 --- /dev/null +++ b/Task/Averages-Root-mean-square/Euphoria/averages-root-mean-square.eu @@ -0,0 +1,14 @@ +function rms(sequence s) + atom sum + if length(s) = 0 then + return 0 + end if + sum = 0 + for i = 1 to length(s) do + sum += power(s[i],2) + end for + return sqrt(sum/length(s)) +end function + +constant s = {1,2,3,4,5,6,7,8,9,10} +? rms(s) diff --git a/Task/Averages-Root-mean-square/Frink/averages-root-mean-square.frink b/Task/Averages-Root-mean-square/Frink/averages-root-mean-square.frink new file mode 100644 index 0000000000..c2668d12c4 --- /dev/null +++ b/Task/Averages-Root-mean-square/Frink/averages-root-mean-square.frink @@ -0,0 +1,3 @@ +rms[array] := sqrt[sum[map[{|x| x^2}, array]] / length[array]] + +println[rms[array[1 to 10]]] diff --git a/Task/Averages-Root-mean-square/Kotlin/averages-root-mean-square.kts b/Task/Averages-Root-mean-square/Kotlin/averages-root-mean-square.kts index 7faec39916..b31b1ec432 100644 --- a/Task/Averages-Root-mean-square/Kotlin/averages-root-mean-square.kts +++ b/Task/Averages-Root-mean-square/Kotlin/averages-root-mean-square.kts @@ -1,7 +1,7 @@ // version 1.0.5-2 fun quadraticMean(vector: Array