The new function is computed by repeated squaring.
Previous
Home
Contents
Next
Chapter 23: Sample programs
In this chapter we show several examples of Aldor programs. The first few give a brief introduction to the language, followed by some examples using more advanced features of the language. The final few examples show how Aldor can variously emulate or interact with other languages.
This chapter supplements the material in chapter 2 and
in part II, the language description.
23.1 : Hello
This program prints out a familiar greeting, and then exits. Line 1 allows the use of the base Aldor library in this program. Line 3 prints the greeting. The program shows how a simple program is written, and the syntax for printing objects.
1 #include "aldor" 2 3 print << "Hello, world!" << newline;
<<'' is an infix operator that
prints an object to a given stream, and returns the stream as a
value. This allows a cascade of ``<<'' calls.
23.2 : Fatorial
The next example shows how to define and call functions in Aldor, and a simple form of iteration.
1 #include "aldor"
2
3 rfact(n: Integer): Integer == if n = 0 then 1 else n*rfact(n-1);
4
5 ifact(n: Integer): Integer == {
6 i := 1;
7 while n > 1 repeat {
8 i := i * n;
9 n := n - 1;
10 }
11 i
12 }
This program defines two functions for calculating the factorial of an integer. The first shows a simple recursive version, the second is an iterative version.
Integer 1
to i. Note that no declaration is
needed if the compiler can infer the type of i.
In this example, 1
must have been exported from the domain Integer. If, for example,
SingleInteger was also imported, a declaration would have been
necessary.
23.3 : Greetings
Most operations in Aldor are defined in and exported by domains. In order to import from a domain, the import statement is used. Imports implicitly happen for the types of parameters of a function, and its return value. The example program below shows the use of the import statement, and also how to read user input.
1 #include "aldor"
2
3 -- function to prompt for and return the user's name from the console
4
5 import from InFile; -- so we can do input
6 import from StandardIO; -- for stdin
7
8 readName(): String == {
9 print << "What is your name?" << newline;
10 line := readline! stdin;
11 -- delete the trailing newline, and return the result
12 rightTrim(line, newline);
13 }
14
15 greet(): () == {
16 name := readName();
17 print << "Hallo " << name << ", and goodbye..." << newline;
18 }
19
20 greet();
This program declares functions to read a name from the console, and then print a personalized note for that name.
The program produces the following output (user input is in italic):
What is your name?
Ethel T Aardvark
Hallo Ethel T Aardvark, and goodbye...
23.4 : Cycle
This example demonstrates the manipulation of functions as first-class values, creating new closures over the course of the computation and multiple valued returns.
1 #include "aldor.as"
2
3 import from Integer;
4
5 -- Multiple value returns and functional composition.
6 -- Only creating the closures by * should allocate storage.
7
8 I ==> Integer;
9 III ==> (I,I,I);
10 MapIII ==> (I,I,I) -> (I,I,I);
11
12 id: MapIII ==
13 (i:I, j:I, k: I): III +-> (i,j,k);
14
15 (f: MapIII) * (g: MapIII): MapIII ==
16 (i:I, j:I, k: I): III +-> f g (i,j,k);
17
18 (f: MapIII) ^ (p: Integer): MapIII == {
19 p < 1 => id;
20 p = 1 => f;
21 odd? p => f*(f*f)^(p quo 2);
22 (f*f)^(p quo 2);
23 }
24
25 -- test routine
26 main(): () == {
27 cycle(a: I, b: I, c: I): III == (c, a, b);
28
29 printIII(a: I, b: I, c: I): () == {
30 import from String;
31 print << "a = " << a << " b = "
32 << b << " c = " << c << newline
33 }
34 printIII (cycle(1,2,3));
35 printIII (cycle cycle (1,2,3));
36 printIII ((cycle*cycle)(1,2,3));
37 printIII ((cycle^10) (1,2,3));
38 }
39
40 main()
The new function is computed by repeated squaring.
The program produces the following output:
a = 3 b = 1 c = 2 a = 2 b = 3 c = 1 a = 2 b = 3 c = 1 a = 3 b = 1 c = 2
23.5 : Generators
Iteration in Aldor is mainly achieved through the use of generators. These are objects representing the state of an iteration, and may be passed around as first-class values. There are two ways of creating generators in Aldor: The generate keyword, and the collect form, created by iterators.
1 #include "aldor"
2
3 F ==> DoubleFloat;
4
5 floatSequence(): Generator F == {
6 import from F, DoubleFloatElementaryFunctions;
7 generate {
8 x := 0.0;
9 repeat {
10 yield exp(-x*x);
11 x := x + 0.05;
12 }
13 }
14 }
15
16 runningMean(g: Generator F): Generator F == {
17 n: Integer := 0;
18 sum: F := 0;
19 generate {
20 for x in g repeat {
21 sum := sum + x;
22 n := n + 1;
23 yield sum/(n::F)
24 }
25 }
26 }
27
28 Test(): () == {
29 import from F, SingleInteger;
30 for i in runningMean(x for x in step(11)(0.0, 1.0)) repeat
31 print << i << newline;
32
33 for i in 1..10
34 for x in runningMean(floatSequence()) repeat
35 print << "next: " << x << newline
36 }
37
38 Test()
DoubleFloats.
There is a further example on the use of generators in
section 23.8
23.6 : Symbol
Most programming in Aldor is done by defining domains and packages. Here we give a small example of a domain. A package is simply a domain which does not export any operations involving values of type %.
Typically, writing a domain is done in four stages:
1 #include "aldor"
2
3 Symbol: BasicType with {
4 name: % -> String; ++ the name of the symbol
5 coerce: String -> %; ++ conversion operations
6 coerce: % -> String;
7 } == add {
8 Rep ==> String;
9
10 import from Rep, Pointer;
11 import from HashTable(String, %);
12
13 local symTab := table();
14
15 name(sym: %): String == sym::String;
16
17 coerce(sym: %): String == rep(sym);
18
19 coerce(s: String): % == {
20 (found, val) := search(symTab, s, per "");
21 found => val;
22 str := copy s;
23 symTab.str := per str;
24 per str;
25 }
26
27 (s1: %) = (s2: %): Boolean == rep s1 = rep s2;
28 (p: TextWriter) << (sym: %): TextWriter ==
29 p << "'" << sym::String << "'";
30 sample: % == per("");
31 }
32
33 Test(): () == {
34 import from Symbol;
35
36 print << "hello"::Symbol << newline;
37 }
Symbol is a Domain
which implements BasicType and
provides 3 additional operations.
Domain''.
Symbols,
our new type are represented. In this case,
we just use a string. If the signature required that additional
information was stored on the symbol we might want to use a different
representation.
23.7 : Stack
It is possible to define a function whose return type is a domain. In this case, the result is called a parameterized domain. The example is a simple stack with a few operations for creating new stacks, as well as pushing and popping values from an existing stack.
1 #include "aldor"
2
3 -- implementation of stacks via lists
4 -- the lines starting with ++ are saved in the output of
5 -- the compiler, and may be browsed with an appropriate tool
6 Stack(S: BasicType): BasicType with {
7 empty?: % -> Boolean; ++ test for an empty stack
8 empty: () -> %; ++ create an empty stack
9 push!:(S, %) -> %; ++ put a new element onto the stack
10 pop!: % -> S;
11 ++ remove the top element and return it
12 top: % -> S; ++ return the top of the stack
13
14 export from S;
15 -- expose all operations from S
16 -- when Stack S is imported
17 } == add {
18 -- Stacks are represented using a list.
19 -- To go between the representation and % we use the
20 -- rep and per functions.
21 Rep == Record(contents: List S);
22 import from Rep;
23
24 -- utility functions
25 local contents(stack: %): List S == rep(stack).contents;
26
27 -- simple functions
28 empty(): % == per [empty()];
29 empty?(s: %): Boolean == empty? contents s;
30 top(s: %): S == first contents s;
31
32 push!(elt: S, s: %): % == {
33 rep(s).contents := cons(elt, contents s);
34 s
35 }
36
37 pop!(s: %): S == {
38 next := first contents s;
39 rep(s).contents := disposeHead! contents s;
40 next;
41 }
42
43 -- needed to satisfy BasicType
44 (p: TextWriter) << (s: %): TextWriter == p << "";
45 (a: %) = (b: %): Boolean == error "no equality on stacks";
46
47 sample: % == empty();
48 }
49
50
51 test(): () == {
52 import from Stack SingleInteger;
53 import from List SingleInteger;
54 l := [1,2,3,4,5,6];
55 stack : Stack SingleInteger := empty();
56 for x in l repeat
57 push!(x, stack);
58 print << "stack is:" << stack << newline;
59 while not empty? stack repeat {
60 print << "Next is: " << top stack << newline;
61 pop! stack;
62 }
63 }
64
The chosen representation type is a list over the same domain as the stack. This allows us to implement the operations with minimum complications. A better representation might be a linked list of arrays, but this would clutter the example more than necessary.
Once the domain is defined, it may be tested. Aldor's interactive
loop, aldor -G loop is useful here.
% aldor -G loop
%1 >> #include "stack.as"
()@
with
== add
%2 >> import from Stack SingleInteger, SingleInteger
%3 >> s: Stack SingleInteger := empty()
<stack> @ Stack(SingleInteger)
%4 >> push!(12, s)
<stack> @ Stack(SingleInteger)
%4 >> top s
12 @ SingleInteger
%5 >> pop! s
12 @ SingleInteger
We should probably test it a little further (e.g. boundary conditions),
but this gives the general idea.
23.8 : Recursive structures
This program shows a recursively defined data type: the type of binary trees parameterized with respect to the type of data placed on the interior nodes. This tree type provides several generators which allow the trees to be traversed in different ways.
1 #include "aldor.as"
2
3 Tree(S: BasicType): BasicType with {
4 export from S;
5
6 empty: %;
7 tree: S -> %;
8 tree: (S, %, %) -> %;
9
10 empty?: % -> Boolean;
11
12 left: % -> %;
13 right: % -> %;
14 node: % -> S;
15
16 preorder: % -> Generator S;
17 inorder: % -> Generator S;
18 postorder: % -> Generator S;
19 }
20 == add {
21 Rep == Record(node: S, left: %, right: %);
22 import from Rep;
23
24 empty: % == nil$Pointer pretend %;
25 empty?(t: %): Boolean == nil?(t pretend Pointer)$Pointer;
26
27 tree(s: S): % == per [s, empty, empty];
28 tree(s: S, l: %, r: %): % == per [s, l, r];
29
30 local nonempty(t: %): Rep == {
31 empty? t => error "Taking a part of a non-empty tree";
32 rep t
33 }
34
35 left (t: %): % == nonempty(t).left;
36 right(t: %): % == nonempty(t).right;
37 node (t: %): S == nonempty(t).node;
38
39 preorder(t: %): Generator S == generate {
40 if not empty? t then {
41 yield node t;
42 for n in preorder left t repeat yield n;
43 for n in preorder right t repeat yield n;
44 }
45 }
46
47 inorder(t: %): Generator S == generate {
48 if not empty? t then {
49 for n in inorder left t repeat yield n;
50 yield node t;
51 for n in inorder right t repeat yield n;
52 }
53 }
54 postorder(t: %): Generator S == generate {
55 if not empty? t then {
56 for n in postorder left t repeat yield n;
57 for n in postorder right t repeat yield n;
58 yield node t;
59 }
60 }
61
62 (tw: TextWriter) << (t: %): TextWriter == {
63 import from String;
64 import from S;
65
66 empty? t => tw << "empty";
67 empty? left t and empty? right t => tw << "tree " << node t;
68
69 tw << "tree(" << node t << ", "
70 << left t << ", " << right t << ")"
71 }
72
73 sample: % == empty;
74
75 (t1: %) = (t2: %): Boolean == {
76 import from S;
77 empty? t1 and empty? t2 => true;
78 empty? t1 or empty? t2 => false;
79 node t1 = node t2 and left t1 = left t2 and right t1 = right t2
80 }
81 }
82
83 import from Tree String;
84 import from List String;
85
86 t := tree("*", tree("1", tree "a", tree "b"),
87 tree("2", tree "c", tree "d"));
88
89 print << "The tree is " << t << newline;
90 print << "Preorder: " << [preorder t] << newline;
91 print << "Inorder: " << [inorder t] << newline;
92 print << "Postorder: " << [postorder t] << newline;
When compiled and run, this program gives the following output:
The tree is tree(*, tree(1, treea, tree b), tree(2, tree c, tree d)) Preorder: list(*, 1, a ,b, 2, c, d) Inorder: list(a, 1, b, *, c, 2, d) Postorder: list(a, b, 1, c, d, 2, *)
23.9 : Swaps
Higher order functions which construct types are first-class values. This example shows how to swap structure layers in a data type by using higher order functions as parameters to a generic program.
1 #include "aldor" 2 #pile 3 4 I ==> SingleInteger; 5 Ag ==> (S: BasicType) -> LinearAggregate S; 6 7 -- This function takes two type constructors as arguments and 8 -- produces a new function to swap aggregate data structure layers. 9 10 swap(X:Ag,Y:Ag)(S:BasicType)(x:X Y S):Y X S == [[s for s in y] for y in x] 11 12 -- Form an array of lists: 13 14 al: Array List I := array(list(i+j-1 for i in 1..3) for j in 1..3) 15 16 print << "This is an array of lists: " << newline 17 print << al << newline << newline 18 19 -- Swap the structure layers: 20 21 la: List Array I := swap(Array,List)(I)(al) 22 23 print << "This is a list of arrays: " << newline 24 print << la << newline
X Y S for the outer iteration,
Y S for the inner iteration,
X S as the inner constructor,
Y X S as the outer constructor.
Array
and List layers.
When executed via ``Aldorcmd -G run swap.as,'' the following output is produced.
This is an array of lists: array(list(1, 2, 3), list(2, 3, 4), list(3, 4, 5)) This is a list of arrays: list(array(1, 2, 3), array(2, 3, 4), array(3, 4, 5)
23.10 : Objects
In Aldor, values are not self-identifying -- there is no way of retrieving a given value's type from the value itself.
The Aldor library provides this functionality in the object datatype, which holds both a value and its type.
The following example shows a use of this library.
1 #include "aldor"
2
3 -- BasicType objects --------------------------------------------------
4 --
5 -- These objects can be printed because each belongs to some BasicType.
6 --
7 bobfun(bob: Object BasicType): () ==
8 f avail bob where
9 f(T: BasicType, t: T) : () == {
10 print << "This prints itself as: " << t << newline;
11 }
12
13
14 import from String, Integer, List Integer;
15
16 boblist: List Object BasicType := [
17 object (String, "Ahem!"),
18 object (Integer, 42),
19 object (List Integer, [1,2,3,4])
20 ];
21
22 for bob in boblist repeat bobfun bob
BasicType.
BasicType.
BasicType objects. Each is formed with the
object function from Object(BasicType).
When run with ``Aldorcmd -G run objectb.as'' this program
This prints itself as: Ahem! This prints itself as: 42 This prints itself as: lsit(1, 2, 3, 4)
The richer the category argument to Object, the more interesting
operations may be performed on the object values. A second example
of using Object is shown below. In this case each object
value belongs to some ring, and this fact is used in the arithmetic
calculation.
1 #include "aldor"
2
3 -- Ring objects ------------------------------------------------------
4 --
5 -- The objects have arithmetic because each belongs to some Ring.
6 --
7 robfun(rob: Object Ring): () == f avail rob where
8
9 f(T: Ring, r: T): () == {
10
11 -- Object-specific arithmetic:
12 s := (r + 1)^3;
13 t := (r - 1)^2;
14 u := s * t;
15
16 -- Object-specific output:
17 print << "r = " << r << newline;
18 print << " s = (r + 1) ^ 3 = " << s << newline;
19 print << " t = (r - 1) ^ 2 = " << t << newline;
20 print << " s * t = " << u << newline;
21
22 -- Can check for additional properties and use if there.
23 if T has Order then {
24 print << "The result is ";
25 if u < 0 then print << "negative";
26 if u > 0 then print << "positive";
27 if u = 0 then print << "zero";
28 print << newline;
29 }
30 else
31 print << "No order for this object." << newline;
32
33 print << newline;
34 }
35
36 import from Complex DoubleFloat, Complex Ratio Integer;
37
38 roblist: List Object Ring := [
39 object ( DoubleFloat, 0.5),
40 object ( Complex DoubleFloat, complex(0.5, 2.0)),
41
42 object ( Integer, -42),
43 object ( Ratio Integer, 1/6),
44 object (Complex Ratio Integer, complex(1/2, 1/3))
45 ];
46
47 for rob in roblist repeat robfun rob
Ring.
Again avail is used to split an object into its component parts
(type and value).
^'' and 1 are provided
by the particular object.
Ring provides a << operation.
T
is seen to also satisfy Order.
The output of running this program with ``Aldorcmd -G run objectb.as'' is shown below.
r = 0.5
s = (r + 1) ^ 3 = 3.375
t = (r - 1) ^ 2 = 0.25
s * t = 0.84375
The result is positive
r = (0.5 + 2 %i)
s = (r + 1) ^ 3 = (-14.625 + 5.5 %i)
t = (r - 1) ^ 2 = (-3.75 + -2 %i)
s * t = (65.84375 + 8.625 %i)
No order for this object.
r = -42
s = (r + 1) ^ 3 = -68921
t = (r - 1) ^ 2 = 1849
s * t = -127434929
The result is negative
r = (1/6)
s = (r + 1) ^ 3 = (343/216)
t = (r - 1) ^ 2 = (25/36)
s * t = (8575/7776)
The result is positive
r = ((1/2) + (1/3) %i)
s = (r + 1) ^ 3 = ((23/8) + (239/108) %i)
t = (r - 1) ^ 2 = ((5/36) + (-1/3) %i)
s * t = ((2947/2592) + (-2531/3888) %i)
No order for this object.
23.11 : Aldor libraries
Here we give some examples of code which uses a number of domains from the libraries provided with Aldor. Four libraries are provided in the Aldor distribution:
Source code for libaldordemo is provided in the distribution.
It includes the following types:
DirectProduct,
GroebnerPackage,
IndexedBits,
MultiDictionary,
ListMultiDictionary,
MatrixOpDom,
Matrix,
NonNegativeInteger,
PolynomialCategory,
Polynomial,
IntegerPrimesPackage,
RandomNumberSource,
SmallPrimeField and
Vector. To use this library, use #include"aldordemo".
The libaldorX11 library contains declarations for
the data structures and functions found in the Xlib library.
This library provides an interface to the
low level X Window System R11 functions, on top of which can be built various
toolkits.
23.12 : Tables
The next example shows a possible implementation of a Table datatype
using a hash table (this file is included in the aldor library).
1 -----------------------------------------------------------------------------
2 ----
3 ---- table.as: Generic hash tables.
4 ----
5 -----------------------------------------------------------------------------
6 ---- Copyright The Numerical Algorithms Group Limited 1991, 1992, 1993, 1994.
7 -----------------------------------------------------------------------------
8 #include "aldor"
9
10 Hash ==> SingleInteger;
11
12 +++ `HashTable(Key, Val)' provides a parameterized hash-table data type.
13
14 HashTable(Key: BasicType, Value: BasicType): BasicType with {
15
16 export from Key;
17 export from Value;
18
19 table: () -> %;
20 ++ `table()' creates a new table using the equality test `='
21 ++ and the hash function `hash' from the `Key' type.
22
23 eqtable: () -> %;
24 ++ `eqtable()' creates a new table using instance equality.
25
26 table: ((Key, Key) -> Boolean, Key->Hash) -> %;
27 ++ `table(=, hash)' creates a new hash table using the
28 ++ equality test `=' and the hash function `hash'.
29
30 copy: % -> %;
31 ++ `copy t' creates a copy of the table `t'.
32
33 #: % -> SingleInteger;
34 ++ `#t' returns the number of elements in `t'.
35
36 search: (%, Key, Value) -> (Boolean, Value);
37 ++ `(b,v) := search(t,k,d)' searches table `t' for the value
38 ++ associated with key `k'. If there is such a value, `vk',
39 ++ then `b' is set to `true' and `v' is set to `vk'.
40 ++ Otherwise `b' is `false' and `v' is set to `d'.
41
42 apply: (%, Key) -> Value;
43 ++ `t.k' searches the table `t' for the value associated with
44 ++ the key `k'. It is an error if there is no value for `k'.
45
46 set!: (%, Key, Value) -> Value;
47 ++ `t.k := val' associates `val' with `k' in `t'.
48
49 drop!: (%, Key) -> Value;
50 ++ `drop!(t, k)' removes the entry for `k' in `t'.
51
52 dispose!: % -> ();
53 ++ `dispose! t' indicates a table will no longer be used.
54
55 generator: % -> Generator Cross(Key, Value);
56 ++ `generator t' is a generator which produces all the
57 ++ `(key, value)' pairs from `t'.
58 }
59 == add {
60 -- Parameters to tune table performance.
61 InitBuckC ==> primes.3;
62 MaxLoad ==> 5.0;
63 MinLoad ==> 0.5;
64
65 -- primes.i is the largest prime <= 2^i.
66 local primes: Array SingleInteger == [
67 2, 3, 7, 13,
68 31, 61, 127, 251,
69 509, 1021, 2039, 4093,
70 8191, 16381, 32749, 65521,
71 131071, 262139, 524287, 1048573,
72 2097143, 4194301, 8388593, 16777213,
73 33554393, 67108859, 134217689, 268435399,
74 536870909, 1073741789, 2147483647, 4294967291
75 ];
76 local lg(n: SingleInteger): SingleInteger == {
77 p := 1;
78 for i in 0.. repeat { if n <= p then return i; p := p + p; }
79 never
80 }
81
82 -- Representation
83 Entry ==> Record(key: Key, value: Value, hash: Hash);
84
85 Rep ==> Record(isEq?: Boolean,
86 equal: (Key, Key) -> Boolean,
87 hash: (Key) -> Hash,
88 count: SingleInteger,
89 buckv: Array List Entry);
90
91 -- Local representation operaitons
92 import from Rep;
93
94 local new(isEq?: Boolean, e: (Key,Key)->Boolean, h: Key->Hash): % ==
95 per [isEq?, e, h, 0, new(InitBuckC, nil)];
96
97 local isEq? (t: %): Boolean == rep(t).isEq?;
98 local hash (t: %): (Key) -> Hash == rep(t).hash;
99 local equal (t: %): (Key,Key) -> Boolean == rep(t).equal;
100 local buckv (t: %): Array List Entry == rep(t).buckv;
101 local buckc (t: %): SingleInteger == #rep(t).buckv;
102
103 local inc!(t: %): () == {
104 import from SingleFloat;
105 rep(t).count := rep(t).count + 1;
106 if #t::SingleFloat/buckc(t)::SingleFloat > MaxLoad then
107 enlarge! t;
108 }
109 local dec!(t: %): () == {
110 import from SingleFloat;
111 rep(t).count := rep(t).count - 1;
112 if #t::SingleFloat/buckc(t)::SingleFloat < MinLoad then
113 shrink! t;
114 }
115
116 local peq(k1: Key, k2: Key): Boolean == {
117 import from Pointer;
118 k1 pretend Pointer = k2 pretend Pointer
119 }
120 local phash(k1: Key): Hash == {
121 k1 pretend Pointer pretend Hash
122 }
123
124 -- Find the chain for k, moving the link to the front on success.
125 local findChain(t: %, k: Key): SingleInteger == {
126 h := hash(t)(k);
127 n := h mod buckc(t) + 1;
128 b := buckv(t).n;
129 p := nil; -- Previous link or nil.
130
131 while b repeat {
132 e := first b;
133 if h = e.hash then {
134 if isEq? t or equal(t)(e.key, k) then {
135 -- Move to front
136 if p then {
137 p.rest := b.rest;
138 b.rest := buckv(t).n;
139 buckv(t).n := b;
140 }
141 return n;
142 }
143 }
144 p := b;
145 b := rest b;
146 }
147 return 0;
148 }
149
150 -- Resize the table, larger or smaller.
151 local enlarge!(t: %): % == resize!(t, lg buckc(t) + 1);
152 local shrink! (t: %): % == resize!(t, lg buckc(t) - 1);
153
154 local resize!(t: %, sizeix: SingleInteger): % == {
155 sizeix < 1 or sizeix > #primes => t;
156
157 nbuckc := primes sizeix;
158 nbuckv := new(nbuckc, nil);
159
160 for b0 in buckv t repeat {
161 b := b0;
162 while b repeat {
163 hd := b;
164 b := b.rest;
165
166 n := (hd.first.hash mod nbuckc) + 1;
167 hd.rest := nbuckv.n;
168 nbuckv.n := b0;
169 }
170 }
171 dispose! rep(t).buckv;
172 rep(t).buckv := nbuckv;
173 t;
174 }
175
176 -- Exported operations
177 sample: % == table();
178 (t1: %) = (t2: %): Boolean == {
179 import from Pointer;
180 t1 pretend Pointer = t2 pretend Pointer
181 }
182 (out: TextWriter) << (t: %): TextWriter == {
183 out << "table(";
184 any? := false;
185 for b in buckv(t) repeat
186 for e in b repeat {
187 if any? then out << ", " else any? := true;
188 out << e.key << " = " << e.value;
189 }
190 out << ")"
191 }
192
193 #(t: %): SingleInteger == rep(t).count;
194
195 eqtable(): % == new(true, peq, phash);
196 table(): % == new(false, =$Key, hash$Key);
197 table(eq:(Key,Key)->Boolean, hash:Key->Hash): % == new(false,eq,hash);
198
199 copy(t: %): % ==
200 per [isEq? t, equal t, hash t, #t,
201 [[[e.key, e.value, e.hash] for e in b] for b in buckv t]];
202
203 search(t: %, k: Key, def: Value): (Boolean, Value) == {
204 n := findChain(t, k);
205 if n = 0 then
206 (false, def)
207 else
208 (true, buckv(t).n.first.value)
209 }
210 apply(t: %, k: Key) : Value == {
211 n := findChain(t, k);
212 n = 0 => error "Element missing from table.";
213 buckv(t).n.first.value;
214 }
215 set!(t: %, k: Key, v: Value) : Value == {
216 n := findChain(t, k);
217 n > 0 => buckv(t).n.first.value := v;
218 h := hash(t)(k);
219 n := (h mod buckc(t)) + 1;
220 buckv(t).n := cons([k,v,h], buckv(t).n);
221 inc! t;
222 v;
223 }
224 drop!(t: %, k: Key): Value == {
225 n := findChain(t, k);
226 n = 0 => error "Element missing from table.";
227 e := buckv(t).n.first;
228 v := e.value;
229 buckv(t).n := disposeHead! buckv(t).n; -- Dispose of the link.
230 dispose! e; -- Dispose of the record.
231 dec! t;
232 v;
233 }
234
235 dispose!(t: %): () == {
236 for b in buckv(t) repeat dispose! b;
237 dispose! buckv(t);
238 dispose! rep(t);
239 }
240
241 generator(t: %): Generator Cross(Key, Value) == generate {
242 for b in buckv t repeat
243 for e in b repeat {
244 c: Cross(Key, Value) := (e.key, e.value);
245 yield c
246 }
247 }
248 }
23.13 : Floating point
The next example demonstrates the use of arbitrary precision floating point numbers
1 #pile
2 #include "aldor"
3
4 import from Float, Integer, FormattedOutput
5
6 digits 50
7
8 a: Float := 1
9 b := pi()
10 c := 21.3456e-5
11
12 print("This is ~1 + ~1:~n~2~n~n") (<<a, <<a+a)
13 print("This is the sqrt of ~1:~n~2~n~n")(<<a+a, <<sqrt(a+a))
14 print("This is exp(~1):~n~2~n~n") (<<a, << exp1())
15 print("This is pi:~n~1~n~n") (<<b)
16 print("This is pi squared:~n~1~n~n") (<<b*b)
17 print("This is 21.3456e-5:~n~1~n~n") (<<c)
18 print("This is cos(pi):~n~1~n~n") (<<cos pi())
19 print("This is sin(pi/~1):~n~2~n~n") (<<a+a, <<sin(pi()/(a+a)))
20 print("This is log(exp(1)):~n~1~n~n") (<<log exp1())
21 print("This is exp(~1):~n~2~n~n") (<<a+a, <<exp(a+a))
22 print("This is log(exp(~1)):~n~2~n~n") (<<a+a, <<log exp(a+a)
23 print("This is atan(tan(~1)):~n~2~n~n") (<<a+a, <<atan tan(a+a))
24 print("This is tan(atan(~1)):~n~2~n~n") (<<a+a, <<tan atan(a+a))
When executed via ``Aldorcmd -G run float1.as,'' the following output is produced.
This is 1.0 + 1.0: 2.0 This is the sqrt of 2.0: 1.4142135623 7309504880 1688724209 6980785696 718753769 This is exp(1.0): 2.7182818284 5904523536 0287471352 6624977572 470937 This is pi: 3.1415926535 8979323846 2643383279 5028841971 693993751 This is pi squared: 9.8696044010 8935861883 4490999876 1511353136 994072408 This is 21.3456e-5: 0.000213456 This is cos(pi): -1.0 This is sin(pi/2.0): 1.0 This is log(exp(1)): 1.0 This is exp(2.0): 7.3890560989 3065022723 0427460575 0078131803 155705519 This is log(exp(2.0)): 2.0 This is atan(tan(2.0)): -1.1415926535 8979323846 2643383279 5028841971 693993751 This is tan(atan(2.0)): 2.0
23.14 : Mandel
The next example shows the use of machine-level floating point in Aldor.
1 #pile 2 #include "aldor.as" 3 4 SI ==> SingleInteger 5 F ==> DoubleFloat 6 CF ==> Complex F 7 8 import from CF 9 inline from CF 10 11 default minR, maxR, minI, maxI: F 12 default numR, numI, maxIters: SI 13 default drawPt: (r: SI, i: SI, n: SI) -> () 14 15 drawMand(minR, maxR, numR, minI, maxI, numI, drawPt, maxIters): () == 16 17 mandel(c: CF): SI == 18 z: CF := 0; 19 n: SI := 0; 20 while norm z < 4.0 for free n in 1..maxIters repeat 21 z := z*z + c 22 n 23 24 for i in step(numI)(minI, maxI) for ic in 1..numI repeat 25 for r in step(numR)(minR, maxR) for rc in 1..numR repeat 26 drawPt(rc, ic, mandel complex(r,i)) 27 28 import from F 29 maxN: SI == 100 30 maxX: SI == 25 31 maxY: SI == 25 32 33 drawPoint(x: SI, y: SI, n: SI): () == 34 import from TextWriter 35 if n = maxN then print << " " 36 else if n < 10 then print << " " << n 37 else print << " " << n 38 if x = maxX then print << newline 39 40 drawMand(-2.0, -1.0, maxX, -0.5, 0.5, maxY, drawPoint, maxN)
Machine level operations are done inline when the optimizer is used
while compiling (use the options ``-Q3 -Qinline-limit=10'').
This has the result that the generated code speed is
comparable with that of the equivalent code in languages such as C.
23.15 : Gröbner bases
Some symbolic algebra packages are supplied in the Aldor
demonstration library. For example, GroebnerPackage provides a
mechanism for computing the Gröbner basis of a list of polynomials.
(These may be used to solve polynomial systems of equations,
among other things.)
Compile this file with the -laldordemo option to link with the appropriate
library.
1 #include "aldor"
2 #include "aldordemo"
3 #pile
4
5 R ==> Integer
6 import from R
7
8 hdp ==> HomogeneousDirectProduct(retract 2)
9 import from hdp
10
11 poly ==> Polynomial(R, hdp)
12 import from poly
13
14 import from GroebnerPackage(R, hdp, poly)
15
16 pp(s: String, polys: List poly): () ==
17 print << s << newline
18 for p in polys repeat print << " " << p << newline
19
20 x:= var unitVector retract 1
21 y:= var unitVector retract 2
22
23
24 p1 := x + y
25 p2 := x - y
26 q1 := p1 * p2
27 q2 := p1 * p1
28 l1: List poly := [q1,q2]
29 base := groebner l1
30
31 pp("GB of ", l1)
32 pp("is", base)
33
34
35 print << newline
36
37 f1 := x^4-3*x^2*y^2 + y^4
38 f2 := x*y^3-x^3*y
39 l2:List poly := [f1,f2]
40 base := groebner l2
41
42
43 pp("GB of ", l2)
44 pp("is", base)
When executed via ``aldor -G run gbtest1.as -L aldordemo'' the program produces the following output:
GB of X^(2,0) + -1*X^(0,2) X^(2,0) + 2*X^(1,1) + X^(0,2) is X^(2,0) + -1*X^(0,2) X^(1,1) + X^(0,2) GB of X^(4,0) + -3*X^(2,2) + X^(0,4) -1*X^(3,1) + X^(1,3) is X^(0,7) X^(1,5) -2*X^(2,3) + X^(0,5) X^(4,0) + -3*X^(2,2) + X^(0,4) X^(3,1) + -1*X^(1,3)
23.16 : Integers mod n
This example shows how add-inheritance can be used in the implementation of integers modulo a particular number. This file is part of the aldor library.
1 -----------------------------------------------------------------------------
2 ----
3 ---- imod.as: Modular integer arithmetic.
4 ----
5 -----------------------------------------------------------------------------
6 ---- Copyright The Numerical Algorithms Group Limited 1991, 1992, 1993, 1994.
7 -----------------------------------------------------------------------------
8
9 #include "aldor.as"
10
11 ModularIntegerNumberSystem(I) ==> Ring with {
12 integer:Literal -> %;
13 coerce: I -> %;
14 lift:% -> I;
15 inv: % -> %;
16 /:(%, %) -> %; -- Or error
17 }
18
19
20 ModularIntegerNumberRep(I: IntegerNumberSystem)(n: I): with {
21 0: %;
22 1: %;
23 integer:Literal -> %;
24 coerce: I -> %;
25 zero?: % -> Boolean;
26 =: (%, %) -> Boolean;
27 ~=: (%, %) -> Boolean;
28 +: % -> %;
29 -: % -> %;
30 inv: % -> %;
31 +: (%, %) -> %;
32 -: (%, %) -> %;
33 lift: % -> I;
34 <<: (TextWriter, %) -> TextWriter;
35 }
36 == add {
37 Rep == I;
38 import from Rep;
39
40 0: % == per 0;
41 1: % == per 1;
42
43 (port: TextWriter) << (x: %): TextWriter == port << rep x;
44
45 coerce (i: I): % == per(i mod n);
46 integer(l: Literal): % == per(integer l mod n);
47 lift(x: %): I == rep x;
48
49 zero?(x: %): Boolean== x = 0;
50 (x: %) = (y: %): Boolean == rep(x) = rep(y);
51 (x: %)~= (y: %): Boolean == rep(x) ~= rep(y);
52
53 + (x: %): % == x;
54 - (x: %): % == if x = 0 then 0 else per(n - rep x);
55 (x: %) + (y: %): % == per(if (z := rep x-n+rep y) < 0 then z+n else z);
56 (x: %) - (y: %): % == per(if (z := rep x -rep y) < 0 then z+n else z);
57
58 inv(j: %): % == {
59 local c0, d0, c1, d1: Rep;
60 (c0, d0) := (rep j, n);
61 (c1, d1) := (rep 1, 0);
62 while not zero? d0 repeat {
63 q := c0 quo d0;
64 (c0, d0) := (d0, c0 - q*d0);
65 (c1, d1) := (d1, c1 - q*d1)
66 }
67 if c0 ~= 1 then error "inverse does not exist";
68 if c1 < 0 then c1 := c1 + n;
69 per c1
70 }
71 }
72
73
74 SI ==> SingleInteger;
75
76 SingleIntegerMod(n: SI): ModularIntegerNumberSystem(SI) with {
77 lift: % -> SI
78 }
79 == ModularIntegerNumberRep(SI)(n) add {
80 Rep == SI;
81 coerce(i: SI): % == per(i mod n);
82 coerce(i: Integer): %== per(retract(i mod n::Integer)@SI);
83 (x: %) ^ (k: Integer): %== {
84 if (k<0) then inv(x^(-n))
85 else power(1, x, k)$BinaryPowering(%,*,Integer);
86 }
87 (x: %) ^ (k: SI): % == {
88 if (k<0) then inv(x^(-n))
89 else power(1, x, k)$BinaryPowering(%,*,SI);
90 }
91 (x: %) / (y: %): %== x * inv y;
92 lift(x: %): SI == x pretend SI;
93
94 (x: %) * (y: %): % == {
95 import from Machine;
96 (xx, yy) := (rep x, rep y);
97 xx = 1 => y;
98 yy = 1 => x;
99 -- Small case
100 HalfWord ==> 32767; --!! Should be based on max$Rep
101 (n < HalfWord) or (xx (xx*yy)::%;
102
103 -- Large case
104 (nh, nl) := double_*(xx pretend Word, yy pretend Word);
105 (qh, ql, rm) := doubleDivide(nh, nl, n pretend Word);
106 rm pretend %;
107 }
108 #if 0
109 (x: %) * (y: %): % == {
110 import from Machine;
111 (xx, yy) := (rep x, rep y);
112 (nh, nl) := double_*(xx pretend Word, yy pretend Word);
113 (qh, ql, rm) := doubleDivide(nh, nl, n pretend Word);
114 rm pretend %;
115 }
116 #endif
117 }
118
119
120 IntegerMod(n: Integer): ModularIntegerNumberSystem(Integer) with
121 == ModularIntegerNumberRep(Integer)(n) add {
122 Rep == Integer;
123 coerce(i: SI): % == per(i::Integer mod n);
124 coerce(i: Integer): %== per(i mod n);
125 (x: %) * (y: %): %== per((rep x * rep y) mod n);
126 (x: %) ^ (k: Integer): %== {
127 if (k<0) then inv(x^(-n));
128 else power(1, x, k)$BinaryPowering(%,*,Integer);
129 }
130 (x: %) ^ (k: SI): % == {
131 if (k<0) then inv(x^(-n));
132 else power(1, x, k)$BinaryPowering(%,*,SI);
133 }
134 (x: %) / (y: %): %== x * inv y;
135 }
23.17 : Extensions
Aldor allows the library types to be extended with new operations. For example, one may wish to add a DifferentialRing category to the language. The extension mechanism allows existing domains, such as Integer and Polynomial to include these new categories. The extension mechanism operates via the extend keyword.
The following example allows Segments to be formed over
Ratio types.
This does not work in the base library as it stands because the parameter of
Segment is declared to be of type Steppable (amongst
other things). Currently only Integer datatypes satisfy this category.
extend
1 #include "aldor"
2
3 extend Ratio(I: IntegerNumberSystem): Steppable with == add {
4 stepsBetween(lo: %, hi: %, delta: %): SingleInteger == {
5 import from I;
6 frac := (hi - lo)/delta;
7 if denom frac = 1 then
8 retract(numer frac)
9 else
10 retract(numer frac quo denom frac);
11 }
12 }
13
14 foo(): () == {
15 import from Ratio Integer, Segment Ratio Integer;
16 for r in (1/2)..(5/2) repeat
17 print << r << newline;
18 }
19
20 foo()
23.18 : Text input
In the next example, the Aldor TextReader and TextWriter datatypes are used to provide a number of useful text processing operations.
1 #include "aldor"
2
3 SI==> SingleInteger;
4 Char ==> Character;
5
6 vowel?(c: Char): Boolean ==
7 c = char "a" or c = char "e" or c = char "i"
8 or c = char "o" or c = char "u";
9
10 -- Delete all the vowels.
11 noVowels(i: TextReader): () == {
12 import from Character, TextWriter;
13 for c in i repeat
14 if not vowel? c then write!(print, c);
15 }
16
17
18 --- 'SubString' provides a means of using a substring of a string
19 --- as an object. We could enlarge this definition to include all
20 --- the non-destructive operations on string, and as a side-effect
21 --- printing would be efficient.
22
23 SubString: with {
24 substring: (String, SI, SI) -> %;
25 coerce: % -> String;
26 } == add {
27 Rep ==> Record(str: String, start: SI, len: SI);
28 import from Rep;
29
30 substring(str: String, start: SI, end: SI): % == {
31 per [str, start, end];
32 }
33
34 coerce(substr: %): String == substring explode rep(substr);
35 }
36
37 -- get the columns from a string
38 columns(str: String, sep: Character): Generator SubString == {
39 import from SI, SubString;
40 generate {
41 lastc := 0;
42 n := 0;
43 for free n in 1..
44 for c in str repeat {
45 if c = sep then {
46 yield substring(str, lastc+1,
47 n-lastc- 1);
48 lastc := n;
49 }
50 }
51 -- '2' because the last char is assumed to be a newline
52 yield substring(str, lastc+1, n - lastc - 2);
53 }
54 }
55
56 -- delete the nth column from an input source, putting output to
57 -- an output stream
58
59 delete!(ins: TextReader, out: TextWriter, c: SI, sep: Char): () == {
60 import from SubString;
61 for l in lines ins repeat {
62 tmpStr := "";
63 dosep := false;
64 for n in 1..
65 for col in columns(l, sep) repeat {
66 if dosep then out << sep;
67 dosep := true;
68 if n ~= c then
69 out << col::String;
70 }
71 out << newline;
72 }
73 }
74
75 test(): () == {
76 import from SI, FileName, InFile, Char, TextReader;
77 ins := open filename("/etc/passwd");
78 delete!(reader ins, print, 2, char ":");
79 close ins;
80 }
81
82 capitalize(o: TextWriter): TextWriter == {
83
84 putc(c: Char): () == o << upper c;
85
86 puts(s: String, start: SI, limit: SI): SI == {
87 start >= limit and limit ~= 0 => 0;
88 i := start;
89 while i ~= limit and not end?(s, i) repeat {
90 putc(s.i);
91 i := i + 1;
92 }
93 i - start;
94 }
95
96 writer(putc, puts);
97 }
98
99
100 test2(): () == {
101 import from SI, FileName, InFile, Char;
102 import from TextReader, String;
103 ins := open filename("/etc/passwd");
104 out := capitalize print;
105 str := new(80);
106 while not zero? (line := readline!(ins, str, 1, 80)) repeat
107 out << str;
108 close ins;
109 out << "This will print in capitals" << newline;
110 print << "This won't" << newline;
111 }
112 test();
113 test2();
<< may be used on any TextWriter.
23.19 : Quanc8
The next example gives a Fortran-style program for numeric integration. The program demonstrates how an algorithm described in the pre-structured programming era may be transcribed without introducing errors by reworking its logic. The program was transcribed from the textbook described in the first comment, and produced correct values on its first run. Of course, if you have access to a callable library containing the routines it should be possible to import the operations directly into Aldor.
The goto construct in Aldor takes the name of a label, and transfers control to that label. Labels are introduced by the @ symbol.
1 #include "aldor"
2
3 R ==> DoubleFloat;
4 I ==> SingleInteger;
5
6 +++ quanc8: Quadrature, Newton-Cotes 8-panel
7 +++
8 +++ (This is a literal translation of the Fortran program given
9 +++ in ``Computer Methods for Mathematical Computations'' by Forsythe,
10 +++ Malcolm and Moler, Prentice-Hall 1977.)
11 +++
12 +++ Estimate the integral of fun(x) from a to b to a given tolerance.
13 +++ An automatic adaptive routine based on the 8-panel newton-cotes rule.
14 +++
15 +++ Input:
16 +++ fun The name of the integrand function subprogram f(x).
17 +++ a The lower limit of integration.
18 +++ b The upper limit of integration. (b may be less than a.)
19 +++ relerr A relative error tolerance. (Should be non-negative)
20 +++ abserr An absolute error tolerance. (Should be non-negative)
21 +++
22 +++ Output:
23 +++ result An approximation to the integral hopefully satisfying
24 +++ the least stringent of the two error tolerances.
25 +++ errest An estimate of the magnitute of the actual error.
26 +++ nofun The number of function values used in calculation of result.
27 +++ flag A reliability indicator. If flag is zero, then result
28 +++ probably satisfies the error tolerance. If flag is
29 +++ xxx.yyy then xxx = the number of intervals which have
30 +++ not converged and 0.yyy = the fraction of the interval
31 +++ left to do when the limit on nofun was approached.
32
33 quanc8(fun: R -> R, a: R, b: R, abserr: R, relerr: R):
34 (Xresult: R, Xerrest: R, Xnofun: I, Xflag: R)
35 == {
36 local result, errest, flag: R;
37 local nofun: I;
38 RETURN ==> return (result, errest, nofun, flag);
39
40 local w0, w1, w2, w3, w4, area, x0, f0, stone, step, cor11: R;
41 local qprev, qnow, qdiff, qleft, esterr, tolerr, temp: R;
42 default i, j : I;
43
44 qright: Array R := new(31, 0.0);
45 f: Array R := new(16, 0.0);
46 x: Array R := new(16, 0.0);
47 fsave: Array Array R := [new(30, 0.0) for i in 1..8];
48 xsave: Array Array R := [new(30, 0.0) for i in 1..8];
49
50 local levmin, levmax, levout, nomax, nofin, lev, nim: I;
51
52 --
53 -- *** Stage 1 *** General initializations
54 -- Set constants
55 --
56 levmin := 1;
57 levmax := 30;
58 levout := 6;
59 nomax := 5000;
60 nofin := nomax - 8 * (levmax - levout + 2 ^ (levout + 1));
61 --
62 -- Trouble when nofun reaches nofin
63 --
64 w0 :=3956.0 / 14175.0;
65 w1 := 23552.0 / 14175.0;
66 w2 := -3712.0 / 14175.0;
67 w3 := 41984.0 / 14175.0;
68 w4 := -18160.0 / 14175.0;
69 --
70 -- Initialize running sums to zero.
71 --
72 flag := 0.0;
73 result := 0.0;
74 cor11 := 0.0;
75 errest := 0.0;
76 area := 0.0;
77 nofun := 0;
78 if a = b then RETURN;
79 --
80 -- *** Stage 2 *** Iniitalization for first interval
81 --
82 lev := 0;
83 nim := 1;
84 x0 := a;
85 x(16) := b;
86 qprev := 0.0;
87 f0 := fun(x0);
88 stone := (b - a)/16.0;
89 x(8) := (x0 + x(16)) / 2.0;
90 x(4) := (x0 + x(8) ) / 2.0;
91 x(12) := (x(8) + x(16)) / 2.0;
92 x(2) := (x0 + x(4) ) / 2.0;
93 x(6) := (x(4) + x(8) ) / 2.0;
94 x(10) := (x(8) + x(12)) / 2.0;
95 x(14) := (x(12)+ x(16)) / 2.0;
96 for j in 2..16 by 2 repeat
97 f(j) := fun(x(j));
98 nofun := 9;
99 --
100 -- *** Stage 3 *** Central calculation
101 -- Requires qprev,x0,x1,...,x16,f0,f2,f4,...,f16.
102 -- Calculates x1,x3,...x15, f1,f3,...f15,qleft,qright,
103 -- qnow,qdiff,area.
104 --
105 @L30 x(1) := (x0 + x(2)) / 2.0;
106 f(1) := fun(x(1));
107 for j in 3..15 by 2 repeat {
108 x(j) := (x(j-1) + x(j+1)) / 2.0;
109 f(j) := fun(x(j));
110 }
111 nofun := nofun + 8;
112 step := (x(16) - x0) / 16.0;
113 qleft := (w0*(f0+f(8)) + w1*(f(1)+f(7)) + w2*(f(2)+f(6)) +
114 w3*(f(3)+f(5)) + w4*f(4)) * step;
115 qright(lev+1) := (w0*(f(8) + f(16))+w1*(f(9)+f(15))+w2*(f(10)+
116 f(14)) + w3*(f(11)+f(13)) + w4*f(12)) * step;
117 qnow := qleft + qright(lev+1);
118 qdiff := qnow - qprev;
119 area := area + qdiff;
120 --
121 -- *** Stage 4 *** Interval convergence test
122 --
123 esterr := abs(qdiff) / 1023.0;
124 tolerr := max(abserr, relerr*abs(area)) * (step/stone);
125 if lev < levmin then goto L50;
126 if lev >=levmax then goto L62;
127 if nofun > nofin then goto L60;
128 if esterr <= tolerr then goto L70;
129 --
130 -- *** Stage 5 *** No convergence
131 -- Locate next interval
132 --
133 @L50 nim := 2*nim;
134 lev := lev + 1;
135 --
136 -- Store right hand elements for future use.
137 --
138 for i in 1..8 repeat {
139 fsave(i)(lev) := f(i+8);
140 xsave(i)(lev) := x(i+8);
141 }
142 --
143 -- Assemble left hand elements for immediate use.
144 --
145 qprev := qleft;
146 for i in 1..8 repeat {
147 j := -i;
148 f(2*j+18) := f(j+9);
149 x(2*j+18) := x(j+9);
150 }
151 goto L30;
152 --
153 -- *** Stage 6 *** Trouble section
154 -- Number of function values is about to exceed limit.
155 --
156 @L60 nofin := 2*nofin;
157 levmax := levout;
158 flag := flag + (b - x0)/(b - a);
159 goto L70;
160 --
161 -- Current level is levmax.
162 --
163 @L62 flag := flag + 1;
164 --
165 -- *** Stage 7 *** Interval converged
166 -- Add contributions into running sums.
167 --
168 @L70 result := result + qnow;
169 errest := errest + esterr;
170 cor11 := cor11 + qdiff / 1023.0;
171 --
172 -- Locate next interval.
173 --
174 @L72 if nim = 2*(nim quo 2) then goto L75;
175 nim := nim quo 2;
176 lev := lev - 1;
177 goto L72;
178
179 @L75 nim := nim + 1;
180 if lev <= 0 then goto L80;
181 --
182 -- Assemble elements required for the next interval.
183 --
184 qprev := qright(lev);
185 x0 := x(16);
186 f0 := f(16);
187 for i in 1..8 repeat {
188 f(2*i) := fsave(i)(lev);
189 x(2*i) := xsave(i)(lev);
190 }
191 goto L30;
192 --
193 -- *** Stage 8 *** Finalize and return
194 --
195 @L80 result := result + cor11;
196 --
197 -- Make sure errest not less than roundoff level.
198 --
199 if errest = 0.0 then RETURN;
200 @L82 temp := abs(result) + errest;
201 if temp ~= abs(result) then RETURN;
202 errest := 2.0 * errest;
203 goto L82;
204 }
23.20 : X Window System R11
Aldor provides an interface to X Window System R11. The following example draws a Mandelbrot fractal set in a window and allows it to be resized, recolored, etc.
1 ------------------------------------------------------------------------------
2 --
3 -- xmandel.as X Windows version of the Mandelbrot set explorer
4 --
5 ------------------------------------------------------------------------------
6
7 #include "aldor"
8 #include "X11"
9
10 macro {
11 DF == DoubleFloat;
12 CDF == Complex DoubleFloat;
13 Pixel == SingleInteger;
14 }
15
16 ------------------------------------------------------------------------------
17 --
18 -- DoubleFloat to SingleInteger truncation.
19 --
20 ------------------------------------------------------------------------------
21
22 local ibit (a: DF) : Int == {
23 a < 1 => 0;
24 (i, x) := (1@Int, 2.0);
25 while x <= a repeat
26 (i, x) := (2*i, 2.0*x);
27 i;
28 }
29
30 local itrunc (a: DF) : Int == {
31 a < 0 => -itrunc(-a);
32 a < 1 => 0;
33 i := ibit a;
34 i + itrunc(a - i::DF);
35 }
36
37 ------------------------------------------------------------------------------
38 --
39 -- Workaround for Ref(BuiltinSInt)
40 --
41 ------------------------------------------------------------------------------
42
43 #unassert BadRefULong
44
45 #if BadRefULong
46 macro {
47 RefULong == Ref UInt;
48 RefWindow == Ref UInt;
49 }
50
51 import {
52
53 XAllocColorCells:
54 (Display, Colormap, Bool, RefULong, UInt, RefULong, UInt)
55 -> Status;
56 XQueryPointer:
57 (Display, Window, RefWindow, RefWindow, Ref Int, Ref Int,
58 Ref Int, Ref Int, Ref UInt) -> Bool;
59 } from Foreign C;
60
61 #endif
62
63 ------------------------------------------------------------------------------
64 --
65 -- HLS Color values in the HLS color system.
66 --
67 ------------------------------------------------------------------------------
68
69 HLS: with {
70 hls: (DF, DF, DF) -> %;
71
72 hue: % -> DF;
73 lightness: % -> DF;
74 saturation: % -> DF;
75
76 setHLSValues: (%, DF, DF, DF) -> %;
77
78 setHLSColors!: (XColor, %) -> ();
79 setHLSColors!: (XColor, DF, DF, DF) -> ();
80 }
81 == add {
82 Rep ==> Record(hue: DF, lightness: DF, saturation: DF);
83
84 import from Rep;
85
86 hls (h: DF, l: DF, s: DF) : % == per [h, l, s];
87
88 hue (hls: %): DF == rep(hls).hue;
89 lightness (hls: %): DF == rep(hls).lightness;
90 saturation (hls: %): DF == rep(hls).saturation;
91
92 setHLSValues (hls: %, h: DF, l:DF, s: DF) : % == {
93 rep(hls).hue := h;
94 rep(hls).lightness := l;
95 rep(hls).saturation := s;
96 hls
97 }
98
99 setHLSColors! (c: XColor, hls: %) : () ==
100 setHLSColors!(c, hue hls, lightness hls, saturation hls);
101
102 setHLSColors! (c: XColor, h: DF, l: DF, s: DF) : () == {
103 (r: UShort, g: UShort, b: UShort) := hlsToRgb(h, l, s);
104 setColors!(c, r, g, b);
105 }
106
107 hlsToRgb (h: DF, l: DF, s: DF) : Cross(UShort, UShort, UShort) == {
108 local r, g, b: UShort;
109 local m1, m2: DF;
110
111 m2 := if l <= 0.5 then l * (1.0 + s) else l + s - l * s;
112 m1 := 2.0*l - m2;
113
114 r := hlsScale hlsValue(m1, m2, h + 120.0);
115 g := hlsScale hlsValue(m1, m2, h);
116 b := hlsScale hlsValue(m1, m2, h - 120.0);
117
118 (r, g, b)
119 }
120
121 coerce (d: ULong) : DF ==
122 d::Int::DF;
123
124 coerce (d: DF) : UShort ==
125 convert ((itrunc d)::BSInt) ;
126
127 hlsScale (d: DF) : UShort == {
128 local FFFF: ULong == coerce(shift(2,16) - 1);
129 (FFFF::DF * d)::UShort;
130 }
131
132 hlsValue(n1: DF, n2: DF, hue:DF): DF == {
133 if hue > 360.0 then hue := hue - 360.0;
134 if hue < 0.0 then hue := hue + 360.0;
135 hue < 60.0 => (n1 + (n2 - n1) * hue / 60.0);
136 hue < 180.0 => n2;
137 hue < 240.0 => (n1 + (n2 - n1) * (240.0 - hue) / 60.0);
138 n1
139 }
140 }
141
142 ------------------------------------------------------------------------------
143 --
144 -- xmandel
145 --
146 ------------------------------------------------------------------------------
147
148 import from DF;
149
150 inline from CDF, Display, XEvent, Screen, XSizeHints, XGCValues, Ref(Int);
151
152 local {
153 display: Display; -- The X-Windows display structure.
154 screen: Screen; -- The X-Windows screen index.
155 colormap: Colormap; -- The X-Windows colormap id.
156 w: Window; -- The X-Windows top-level window.
157
158 width: UInt; -- The dimensions of the window.
159 height: UInt;
160
161 gc: GC; -- Graphics contex for drawing pixels.
162 lgc: GC; -- Graphics contex for drawing boxes.
163
164 savedWindow: Pixmap; -- A backing pixmap for expose events.
165 saved: Boolean := false; -- True if window has been saved.
166
167 c0: CDF; -- co and c1 define the bounding of the
168 c1: CDF; -- region of the set we will display.
169
170 bandSize: Int :=1; -- Number of colors per iteration.
171 numShades: Int := 100; -- Total colors in colormap.
172
173 -- Data structures mapping color indices into pixel values.
174 maxColors: Int := 256;
175 planes: PrimitiveArray ULong == new(maxColors);
176 pixVals: PrimitiveArray Pixel == new(maxColors);
177
178 -- Up ahead we have a little local color.
179 initcolor: XColor := XColor();
180
181 -- A color function for the initial colors.
182 inithls: HLS := hls(0.0, 0.0, 0.0);
183 visualclass:SingleInteger := 0;
184 }
185
186 coerce(v: PrimitiveArray UInt): Ref(Int) == v pretend Ref(Int);
187
188 -- Create a top-level window of the given size, and map it.
189
190 createWindow(width: UInt, height: UInt): Window == {
191 free display: Display;
192 free screen: Screen;
193 free colormap: Colormap;
194 free w: Window;
195 free gc, lgc: GC;
196 free visualclass: Int;
197
198 local borderWidth: Int == 4;
199 local inputMask: ULong == ButtonPressMask \/
200 ExposureMask \/
201 StructureNotifyMask;
202 local sizeHints: XSizeHints == XSizeHints();
203 local values: XGCValues == XGCValues();
204
205 -- Initialize the display.
206 display := XOpenDisplay("");
207 if not display then
208 print << "Cannot connect to the X11 sever." << newline;
209
210 -- Initialize the screen.
211 screen := XDefaultScreenOfDisplay(display);
212
213 -- get visual class
214 visualclass:=ClassOfVisual(DefaultVisualOfScreen(screen))$Visual;
215 -- Create the window.
216 w := XCreateSimpleWindow(display, RootWindowOfScreen(screen),
217 0, 0, width, height, borderWidth,
218 BlackPixelOfScreen(screen)$Screen,
219 WhitePixelOfScreen(screen)$Screen);
220
221 -- Initialize the colormap.
222 colormap := DefaultColormapOfScreen(screen);
223
224 -- Select the input events the window will process.
225 XSelectInput(display, w, inputMask);
226
227 -- Select the size hints for the window manager.
228 setFlags! (sizeHints, PPosition \/ PSize \/ PMinSize);
229 setX! (sizeHints, 0);
230 setY! (sizeHints, 0);
231 setWidth! (sizeHints, width);
232 setHeight! (sizeHints, height);
233 setMinWidth! (sizeHints, 50);
234 setMinHeight! (sizeHints, 50);
235 XSetNormalHints(display, w, sizeHints);
236
237 -- Create the graphics context for drawing pixels.
238 gc := XCreateGC(display, w, 0, values);
239 XSetLineAttributes(display, gc, 0, LineSolid, CapButt, JoinMiter);
240
241 -- Create the graphics context for drawing boxes.
242 lgc := XCreateGC(display, w, 0, values);
243 XSetLineAttributes(display, lgc, 0, LineSolid, CapButt, JoinMiter);
244 XSetFunction(display, lgc, GXxor);
245 XSetForeground(display, lgc, WhitePixelOfScreen(screen)$Screen);
246
247 -- Map the window on the display.
248 XMapWindow(display, w);
249 w
250 }
251
252 -- Allocate read/write color cells for our pallette.
253
254 allocColorCells(numColors: UInt): () == {
255 status := XAllocColorCells(display, colormap, false,
256 planes pretend Ref ULong, 0, pixVals pretend Ref ULong, numColors);
257 if (status = 0) then
258 print << "AllocColorCells failed" << newline;
259 }
260
261 -- Set the pallette according to the given color function.
262 -- The color function takes a number in the range 0.0..1.0, and
263 -- returns a value in the HLS color system.
264
265 setPallette(shades: Int, colorFunction: (DF -> HLS)): () == {
266 local color:XColor := initcolor;
267 for i in 1..shades for t: DF in step(shades)(0.0, 1.0) repeat {
268 setHLSColors!(color, colorFunction t)$HLS;
269 if even? visualclass then {
270 status:=XAllocColor(display, colormap, color);
271 if (status=0) then print << "XAllocColor failed " << newline;
272 pixVals.i := PixelOfColor(color);
273 } else {
274 setPixel!(color, pixVals.i::Pixel);
275 XStoreColor(display, colormap, color);
276 }
277 }
278 }
279
280 -- The initial color function for setPallette.
281
282 rainbowColors(t: DF): HLS == {
283 local hls: HLS;
284 import {
285 sin: DF -> DF;
286 cos: DF -> DF;
287 } from DoubleFloatElementaryFunctions;
288 local pi: DF == 3.14159;
289
290 hls:= inithls;
291 light: DF := 0.4 + (0.5 - cos (5.0*pi*t)/2.0)/4.0;
292 hue: DF := if t < 0.5 then 240.0 else 30.0;
293 setHLSValues(hls, hue, light, 0.9);
294 hls
295 }
296
297 -- Set the pallette according to the mouse position.
298
299 local {
300 ox: Int := -1;
301 oy: Int := -1;
302 }
303
304 setMouseColors(x: Int,y: Int): () == {
305 free ox, oy: Int;
306
307 if x = ox and y = oy then return;
308 (ox, oy) := (x, y);
309 x:=max(0,min(x,width));
310 y:=max(0,min(y,height));
311 setRainbow(x::DF * 360.0 / width::DF,
312 y::DF * 360.0 / height::DF)
313 }
314
315 local {
316 hue0: DF;
317 delHue: DF;
318 }
319
320 setRainbow(h0: DF, h1: DF): () == {
321 free hue0, delHue: DF;
322
323 hue0 := h0;
324 delHue := h1;
325 setPallette(numShades, mouseRainbow);
326 }
327
328 -- A color function for setPallette.
329
330 mouseRainbow(t: DF): HLS == {
331 local hls: HLS;
332 local colorDelta: DF == 0.5;
333
334 hls := inithls;
335 l: DF := 0.4 + t * colorDelta;
336 setHLSValues(hls, hue0 + t*delHue, l, 0.9 - l/2.0);
337 hls
338 }
339
340 -- Save the screen to a pixmap for later expose events.
341
342 savePixmap(): () == {
343 free saved: Boolean;
344 free savedWindow: Pixmap;
345 savedWindow := XCreatePixmap(display, w, width, height,
346 XDisplayPlanes(display, XDefaultScreen(display)));
347 XCopyArea(display, w, savedWindow, gc, 0, 0, width, height, 0, 0);
348 saved := true;
349 }
350
351 -- Display the backing pixmap.
352
353 showPixmap(): () ==
354 XCopyArea(display, savedWindow, w, gc, 0, 0, width, height, 0, 0);
355
356
357 -- Draw a single point with the n iterations and iters maximum
358 -- iterations at position (i, j) in the top-level window.
359
360 local gcv: XGCValues := XGCValues();
361
362 plotPoint(i: Int, j: Int, iters: Int, n: Int): Int == {
363 index: Int := n mod numShades;
364 pixel: Pixel := BlackPixelOfScreen(screen)$Screen;
365 if (index > 0) then
366 pixel := pixVals.(index+1);
367 setForeground!(gcv, pixel);
368 XChangeGC(display, gc, GCForeground, gcv);
369 XDrawPoint(display, w, gc, i, j);
370 i
371 }
372
373 -- Draw a bounding box.
374
375 drawBox(x0: Int, y0: Int, x1: Int, y1: Int): () == {
376 XDrawLine(display, w, lgc, x0, y0, x1, y0);
377 XDrawLine(display, w, lgc, x1, y0, x1, y1);
378 XDrawLine(display, w, lgc, x1, y1, x0, y1);
379 XDrawLine(display, w, lgc, x0, y1, x0, y0);
380 }
381
382 -- Reads and create a bounding zoom box.
383
384 readZoom(): () == {
385 free c0, c1: CDF;
386 free saved: Boolean;
387 local newEvent: XEvent == XEvent();
388 local nr0, nr1, ni0, ni1, t: DF;
389
390 pw: Ref(Int) := make 0;
391 rx: Ref(Int) := make 0;
392 ry: Ref(Int) := make 0;
393 x : Ref(Int) := make 0;
394 y : Ref(Int) := make 0;
395 kb: Ref(Int) := make 0;
396
397 XQueryPointer(display, w, pw, pw, rx, ry, x, y, kb);
398
399 nx: Ref(Int) := make value x;
400 ny: Ref(Int) := make value y;
401 onx: Int := value x;
402 ony: Int := value y;
403
404 drawBox(value(x), value(y), onx, ony);
405
406 repeat {
407 if XPending(display) = 0 then {
408 XQueryPointer(display, w, pw, pw,
409 rx, ry, nx, ny, kb);
410 if value(nx) ~= onx or value(ny) ~= ony then {
411 drawBox(value(x), value(y), onx, ony);
412 onx := value(nx);
413 ony := value(ny);
414 drawBox(value(x), value(y), onx, ony);
415 }
416 }
417 else {
418 XNextEvent(display, newEvent);
419 if TypeOfEvent(newEvent) ~= ButtonPress then iterate;
420 t := (real(c1) - real(c0)) / width::DF;
421 nr0 := value(x)::DF * t + real(c0);
422 t := (real(c1) - real(c0)) / width::DF;
423 nr1 := value(nx)::DF * t + real(c0);
424
425 if value(ny) > height then ny := make(height);
426 ni0 := (value(y)::DF * (imag(c1) - imag(c0))) /
427 height::DF + imag(c0);
428 ni1 := (value(ny)::DF * (imag(c1) - imag(c0))) /
429 height::DF + imag(c0);
430 c0 := complex(min(nr0, nr1), min(ni0,ni1));
431 c1 := complex(max(nr0, nr1), max(ni0,ni1));
432 saved := false;
433 drawBox(value(x), value(y), value(nx), value(ny));
434 drawMand();
435 break
436 }
437 }
438 }
439
440 readPallete(): () == {
441 local newEvent: XEvent == XEvent();
442
443 pw: Ref(Int) := make 0;
444 x : Ref(Int) := make 0;
445 y : Ref(Int) := make 0;
446 rx: Ref(Int) := make 0;
447 ry: Ref(Int) := make 0;
448 kb: Ref(Int) := make 0;
449
450 XQueryPointer(display, w, pw, pw, rx, ry, x, y, kb);
451
452 nx: Ref(Int) := make value x;
453 ny: Ref(Int) := make value y;
454 onx: Int := value x;
455 ony: Int := value y;
456
457 setMouseColors(onx, ony);
458
459 repeat {
460 if XPending(display) = 0 then {
461 XQueryPointer(display, w, pw, pw,
462 rx, ry, nx, ny, kb);
463 if value(nx) ~= onx or value(ny) ~= ony then {
464 onx := value(nx);
465 ony := value(ny);
466 setMouseColors(onx, ony);
467 }
468 }
469 else {
470 XNextEvent(display, newEvent);
471 if TypeOfEvent(newEvent) ~= ButtonPress then iterate;
472 break;
473 }
474 }
475 }
476
477 -- Handles expose events. Draws the set if it hasn't yet, otherwise
478 -- it displays the backing pixmap.
479
480 drawMand(): () == {
481 if saved then
482 showPixmap();
483 else {
484 drawMandSet(real(c0), real(c1), width, imag(c0), imag(c1),
485 height, plotPoint);
486 savePixmap()
487 }
488 }
489
490 macro {
491 MaxIters == 200;
492 Infinity == 0;
493 }
494
495 +++ Draw the Mnadelbrot set in the given region.
496 +++ The pixel drawing function is passed as a parameter.
497 drawMandSet(minR: DF, maxR: DF, numR: Int,
498 minI: DF, maxI: DF, numI: Int,
499 drawFun: (Int, Int, Int, Int) -> Int): Int == {
500 mandel(c: CDF): Int == {
501 z: CDF := 0;
502 nc: Int := 0;
503
504 for n in 1..MaxIters while norm z < 4.0 repeat {
505 z := z*z + c;
506 nc := n;
507 }
508 if nc = MaxIters then nc := Infinity;
509 nc;
510 }
511
512 for i in step(numI)(minI, maxI) for ic in 0..numI-1 repeat
513 for r in step(numR)(minR, maxR) for rc in 0..numR-1 repeat
514 drawFun(rc, ic, MaxIters, mandel complex(r,i));
515
516 MaxIters;
517 }
518
519 -- Main initialization and event loop.
520
521 main(): () == {
522 free {
523 width: UInt;
524 height: UInt;
525 c0: CDF;
526 c1: CDF;
527 saved: Boolean;
528 }
529 local event: XEvent == XEvent();
530
531 width := 200;
532 height := 200;
533 c0 := complex(-2.1, -1.8);
534 c1 := complex( 1.5, 1.8);
535 createWindow(width, height);
536 if odd? visualclass then allocColorCells(numShades);
537 setPallette(numShades, rainbowColors);
538
539 repeat {
540 XNextEvent(display, event);
541
542 if TypeOfEvent(event) = Expose then
543 drawMand();
544
545 else if TypeOfEvent(event) = ConfigureNotify then {
546 cevent == event::XConfigureEvent;
547
548 if width ~= WidthOfEvent cevent
549 and height ~= HeightOfEvent cevent
550 then {
551 width := WidthOfEvent cevent;
552 height := HeightOfEvent cevent;
553 saved := false;
554 }
555 }
556 else if TypeOfEvent(event) = ButtonPress then {
557 xevent == event::XButtonEvent;
558 if ButtonOfEvent xevent = Button1 then
559 readZoom();
560 else
561 readPallete();
562 }
563 }
564 }
565
566 -- When the program starts, it shows a top-level view of
567 -- the Mandelbrot set. To zoom in, click the left mouse
568 -- button on one corner of a bounding box, then click
569 -- again on the other corner, and the box will expand to
570 -- fill the entire window.
571
572 main();
23.21 : AXIOM library
Aldor programs can run within the AXIOM environment, and can use all the categories, domains and packages supplied by AXIOM. The following example computes the Hilbert polynomial for a set of monomials.
1 -- This file tests for situations when one name covers another.
2
3 #include "aldor.as"
4
5 import SingleInteger
6
7 local y : SingleInteger := 1
8
9 f(x: SingleInteger, w : SingleInteger):SingleInteger ==
10 local w -- bad, parameters cannot be declared free or local
11 print("Parameter x = ")(x)()
12 print("Inner x = ")(x)() where
13 local x : SingleInteger == 3 -- bad, local const with same name as parameter
14 local y : SingleInteger == 4 -- bad, local const with same name as outer variable
15 x
16
17 local
18 q : SingleInteger := 7
19 r : SingleInteger == 7
20
21 q + r where
22 q : SingleInteger := 700 -- give implicit local message
23 r : SingleInteger := 700 -- give implicit local message
24
25 g0(q : SingleInteger): SingleInteger ==
26 print("Inner lexical variable q = ")(q)() where
27 q : SingleInteger := 700 -- give implicit local message
28 print("Parameter q = ")(q)()
29 q
30
31 -- following tests that one cannot assign to a library or archive
32
33 Aldor := Array
34
35 #library AldorDemo "aldordemo"
36 AldorDemo == Array
37
38 local
39 z : SingleInteger := 2
40 u : SingleInteger == 2
41
42 print("Outer lexical variable z = ")(z)()
43 print("Inner lexical variable z = ")(z)() where
44 local z : SingleInteger
45 z := 200 -- ok, this covers outer local
46
47 print("Outer lexical constant u = ")(u)()
48 print("Inner lexical variable u = ")(u)() where
49 local u : SingleInteger
50 u := 200 -- ok, this covers outer local
51
52 g(q : SingleInteger): SingleInteger ==
53 print("Inner lexical variable q = ")(q)() where
54 local q : SingleInteger
55 q := 700
56 print("Parameter q = ")(q)()
57 q
58
59 g(7)
60
61 f2(z: SingleInteger): SingleInteger == -- parameter covers outer local
62 print ( "[Outer z = " )( z )( "] ")
63
64 g2(z: SingleInteger): SingleInteger == -- parameter covers outer parameter
65 print ( "[Inner z = " )( z )( "] ")()
66 z
67
68 g2(z*z + 1)
69
70 f2(100)
71 f2(10000)
72
73 f3(z: SingleInteger, u: SingleInteger): SingleInteger == -- parameters cover outer locals
74 print("Inner z + u = ")(w := z + u)()
75 w
76
77
78 print("Outer z + u = ")(z+u)()
79 f3(200,300)
Note that AXIOM domains and categories are used freely within the program, for example, OrderedSet, Monomial and List.
As well as providing all the AXIOM domains, libaxiom also
extends a few so that features new in Aldor are (apparently)
provided in the old AXIOM domain. As an example, in the function
variables, the List M is iterated using a generator, the
definition of which came from the Aldor extension of List.
Previous
Home
Contents
Next