Welcome to the Dictionary of Programming Languages, a compendium
of computer coding methods assembled to provide information and
aid your appreciation for computer science history.
Browse the dictionary by clicking on a section:
A
B
C
D
E
F
G
H
I
JK
L
M
N
O
P
QR
S
T
UV
WXYZ+
Get a full dump of the dictionary:
List of Names
Short Form
Full Form
HOW TO RETURN index doc:
PUT {} IN where
FOR line.no IN keys doc:
TREAT LINE
RETURN where
TREAT LINE:
FOR word IN split doc[line.no]:
IF word not.in keys where:
PUT {} IN where[word]
INSERT line.no IN where[word]
PROGRAM ONE WHEEL
" Simple model of a dynamical system
" written in ACSL 1, circa 1982.
INITIAL
CINTERVAL CINT = 0.05
ALGORITHM IALG = 4 $ "RK3"
CONSTANT X1IO = 0.0, X2IO=0.0, X1DIC=0.0, X2DIC = 0.0
CONSTANT M1 = 25.0, M2=2.0, DF=100.0, K2=5000
CONSTANT TDONE = 15.0
K1 = 1000.0
END $ "OF INITIALIZATION"
DYNAMIC
DERIVATIVE
X3= STEP(0.0)
X1D = INTEG((-DF/M1)*(X1D-X2D) - (K1/M1)*(X1-X2), X1DIC)
X2D = INTEG((-DF/M1)*(X1D-X2D) - (K1/M1)*(X1-X2), ...
(K2/M2)*(X2-X3*5.0), X2DIC)
X1 = INTEG(X1D,X1IO)
X2 = INTEG(X2D,X2IO)
END "OF DERIVATIVE SECTION"
TERMT(T .GE. TDONE)
END "OF DYNAMIC SECTION"
END "OF PROGRAM"
-- simple programming with floating-point #s with Ada.Float_Text_IO; use Ada.Float_Text_IO; procedure Think is A, B : Float := 0.0; -- A and B initially zero; note the period. I, J : Integer := 1; begin A := B * 7.0; I := J * 3; B := Float(I) / A; Put(B); end Think;
/* An Alef program to parse numbers out of
* the string returned from /dev/time, and
* print them from a separate proc. This is
* a rather lame conglomeration of several
* examples from Bob Flandrea's Alef
* User's Guide
*/
tuple(int, uint, byte*)
strtoui(byte* str, int base)
{
int val;
while(*str != 0 && whitespace(*str))
str ;
if(str == nil || *str == 0)
return(0, 0, str);
while(*str && !whitespace(*str)) {
if(!validdigit(*str, base))
return (-1, val, str 1);
/* extract digit into val */
str ;
}
return(1, val, str);
}
void
receive(chan(uint) c)
{
int s;
s = <-c;
print("%d\n", s);
if (s == 0)
terminate(nil);
}
void
main(void)
{
chan(uint) c;
alloc c;
proc receive(c);
int ret;
uint val;
int fd;
byte *p, buf[128], *newp;
fd = open("/dev/time", OREAD|OCEXEC);
if (fd >= 0) {
read(fd, buf, sizeof(buf));
for(p = buf; *p; p = newp) {
(ret, val, newp) = strtoui(p, 10);
if(ret >= 0) c <-= val;
if(ret == 0) break;
}
}
}
// the main program, calculate the mean of
// some numbers
begin
integer N;
Read Int(N);
begin
real array Data[1:N];
real sum, avg;
integer i;
sum:=0;
for i:=1 step 1 until N do
begin real val;
Read Real(val);
Data[i]:=if val<0 then -val else val
end;
for i:=1 step 1 until N do
sum:=sum Data[i];
avg:=sum/N;
Print Real(avg)
end
end
Here is a better example, written in the
Algol60 publication language, from
Jean Sammet courtesy of
Glyn Webster.
procedure problem (a, b);
value a, b; integer a, b;
begin integer k; real e;
for k := 2 × (a ÷ 2) 1 step 2 until b do
begin
e := if prime(k) then sqrt(3 × k sin(k))
else sqrt(4 × k cos(k));
if prime(k) then putlist(k, e, 'prime')
else putlist(k, e, 'nonprime')
end
end problem;
-- Use the Finder to close all applications
-- (by Joshua D. Baer)
property specialApps : {"Finder"}
tell application "Finder"
set allApps to name of processes
end tell
repeat with someParticularApp in allApps
if specialApps does not contain someParticularApp then
tell application someParticularApp
activate
quit
end tell
end if
end repeat
;; Very simple example of interactive extension ;; for AutoCAD (Defun c:SF2ACRE () (setq SF (getreal "Enter area in square feet: ")) (setq AGREAGE (/ SF 43560.0)) (alert (strcat "\nThe area in acres is " (rtos ARGEAGE 2 2))) )
BEGIN {
if ("'$#argv'"==1) Col="'$1'"; else Col=1
}
{Total = $Col; };
END {
printf "Total for column %d with %d items: %d\n",
Col,NR,Total
}
REM Very very simple QBasic program PRINT "My Menu" PRINT "Press 1 to clear the screen, or 2 to say 'Hello'!" INPUT "What do you want to do"; choice IF choice = 1 THEN GOTO clrscr IF choice = 2 THEN GOTO hello clrscr: CLS PRINT "Done." END hello: PRINT "Hello, hello, hello!" END
// Routine to compute a checksum of a
// named file, simplified from a compiler example.
GET "libhdr"
LET start() = VALOF
$( LET args = VEC 50
LET instream = 0
LET outstream = 0
LET sum = 314159
IF rdargs("FROM/A,TO/K", args, 50) = 0 DO
$( writes("Bad arguments for CHECKSUM*n")
RESULTIS 20
$)
instream := findinput(args!0)
IF instream = 0 DO $( writef("can't open %s*n", args!0)
RESULTIS 20
$)
selectinput(instream)
UNLESS args!1 = 0 DO
$( outstream := findoutput(args!1)
IF outstream = 0 DO $( writef("can't open %s*n", args!1)
endread()
RESULTIS 20
$)
$)
$( LET ch = rdch()
IF ch=endstreamch BREAK
sum := (13*sum + ch) & #xFFFFFFF
$) REPEAT
UNLESS outstream=0 DO selectoutput(outstream)
writef("%n*n", sum)
out:
endread()
UNLESS outstream = 0 DO $( selectoutput(outstream)
endwrite()
$)
RESULTIS 0
$)
v>00p10p>00g:10g\/v ^:&< |:-1p00/2+< >93*^ >00g.@
A Befunge program to generate random integers (by Ken Bateman):
088+>v >+\^1@ 1 \-. >? ^:\ ^+:\_^
(* Link describes a linked list *)
Link:
(# succ: ^Link; (* tail of this Link *)
elm: @integer; (* content element of this Link *)
Insert: (* Insert an element after this Link *)
(# E: @integer; R: ^Link;
enter E
do &Link[]->R[]; (* R denotes a new instance of Link *)
E->R.elm; (* E=R.elm *)
succ[]->R.succ[]; (* tail of this Link = tail of R *)
R[]->succ[]; (* R=tail of this Link *)
#)
#)
(* Test the linked list *)
(# head: @Link
do 1->head.Insert;
2->head.Insert;
6->head.Insert;
24->head.Insert;
( * head = (0 24 6 2 1) *)
#)
DEFINE PROCEDURE "GOLDBACH?" [N]:
BLOCK 0: BEGIN
CELL(0) <= 2;
LOOP AT MOST N TIMES:
BLOCK 1: BEGIN
IF {PRIME?[CELL(0)]
AND PRIM[MINUS[N,CELL(0)]]},
THEN:
BLOCK 2: BEGIN
OUTPUT <= YES;
QUIT BLOCK 0;
BLOCK 2: END
CELL(0) <= CELL(0) + 1;
BLOCK 1: END
BLOCK 0: END
#include <stdio.h>
/* count lines of standard input */
main(int argc, char *argv[]) {
char lbuf[256];
int lcnt;
for(lcnt = 0; fgets(lbuf,sizeof(lbuf) - 1, stdin); cnt );
printf("%d lines\n", lcnt);
exit(0);
}
// Adapted from the paper "The C* Parallel
// Programming Language" by Andrews and Barszcz, 1992.
// Skyline Matrix Problem solution
#define N 4
#define BIG 1024
domain Matrix { float a; int i; int j; } A[N][N];
domain RHS { float b; int i; } B[N];
domain Skyline { float s; int i; int j; } SKY[BIG];
domain Vector { float element; int start; } I[N], J[N];
void main() {
int k,l,m;
float x[N], element;
float rowsum, pivot;
int NonZeros;
readMatrix();
[domain RHS].{ i = (int)(this - &B[0]); }
[domain Matrix].{
int offset = (int) (this - &A[0][0]);
i = offset / N; j = offset % N;
}
for(k = 0; k<N; k ) {
rowsum = 0;
[domain Matrix].{ if (i == k) rowsum = a; }
B[k].b = rowsum;
}
NonZeros = map(); /* put matrix in skyline form? */
for(k=0; k<(N-1); k ) {
[domain Skyline].{
if ((i ==k) && (j==k)) Pivot ,= s;
if (((i>k) && (j==k)) && (I[i].start <= k)) {
s = s / Pivot;
I[i].element = s;
}
if (((i==k) && (j > k)) && (J[j].start <= k)) J[j].element = s;
if (((i > k) && (j > k)) &&
((I[i].start <= k) && J[j].start <= k))
s = s - (I[i].element * J[j].element);
}
}
for(k = (N-1); k > 0; k--) {
[domain Skyline].{
if (((i <= k) && (j ==k)) && (J[k].start <= k))
J[j].element = s;
}
x[k] ,= B[k].b / J[j].element;
[domain Skyline].{
if ((i < k) && (J[k].start < k))
b = b - (J[j].element * x[k]);
}
}
[domain Skyline].{ if (i == 0 && j == 0) Pivot ,= s; }
x[0] = B[0].b / Pivot;
printf("x\n");
for(k = 0; k<N; k ) printf("%f\n",x[k]);
}
// This is just a placehold until I write a
// better example.
#include <iostream.h>
#include <String.h>
main(int argc, char *argv[])
{
String *s1;
s1 = new String("Hello World!");
cout << *s1 << endl << "Length is:" << s1->length() << endl;
}
-- Adapted from Cecil Project v2.0 distribution tests
method copy_file_using_streams(name1@:string, name2@:string):void {
let f1:unix_file := open_file(name1, open_for_reading);
let f2:unix_file := open_file(name2, create_for_writing);
(name1 || " is " || if(f1.is_unreadable, {"not "}, {""}) || "readable").
print_line;
(name2 || " is " || if(f2.is_unreadable, {"not "}, {""}) || "readable").
print_line;
while({ f1.before_end }, { f2.next := f1.next; });
close(f1);
close(f2);
}
let var name1 := ask("Name of input file: ");
let var name2 := ask("Name of output file: ");
print("Copying using streams...");
copy_file_using_streams(name1, name2);
print_line(" done.");
<CFSWITCH EXPRESSION="#ThisTag.ExecutionMode#">
<CFCASE VALUE="start">
<CFIF StructIsEmpty(attributes.EMPINFO)>
<CFOUTPUT>Error. No employee data was passed.</CFOUTPUT>
<CFEXIT METHOD="ExitTag">
<CFELSE>
<!--- Add the employee --->
<CFQUERY NAME="AddEmployee" DATASOURCE="cfsnippets">
INSERT INTO Employees
(FirstName, LastName, Email, Phone, Department)
VALUES
<CFOUTPUT>
(
‘#StructFind(attributes.EMPINFO, "firstname")#’ ,
‘#StructFind(attributes.EMPINFO, "lastname")#’ ,
‘#StructFind(attributes.EMPINFO, "email")#’ ,
‘#StructFind(attributes.EMPINFO, "phone")#’ ,
‘#StructFind(attributes.EMPINFO, "department")#’
)
</CFOUTPUT>
</CFQUERY>
</CFIF>
<CFOUTPUT><HR>Employee Add Complete</CFOUTPUT>
</CFCASE>
</CFSWITCH>
-- still looking for a good code example
#include <cilk.h>
#include <stdlib.h>
#include <stdio.h>
cilk int fib(int n)
{
if (n < 2)
return (n);
else {
int x, y;
x = spawn fib(n - 1);
y = spawn fib(n - 2);
sync;
return (x y);
}
}
cilk int main(int argc, char *argv[])
{
int n, result;
n=atoi(argv[1]);
result=spawn fib(n);
sync;
printf("Result: %d\n", result);
return 0;
}
// Very simple Fibonnacci example adapted from v2.1
// "Introduction to the CLAIRE Programming Language"
begin(fib_module)
fib[n:(0..10)] : integer := (if (n < 2) 1 else fib[n - 1] fib[n - 2])
test() -> (for i in (0 .. 10) printf("fib(~S) = ~S\n",i,fib[i])
end(fib_module)
% Driver and function to compute factorials
% from the PCLU distribution.
start_up = proc ()
pi: stream := stream$primary_input()
po: stream := stream$primary_output()
while true do
stream$puts(po, "Enter an integer (or RETURN to exit): ")
s: string := stream$getl(pi)
if string$empty(s) then break end
n: int := int$parse(s)
except when bad_format:
stream$putl(po, "Illegal integer")
end
stream$putl(po, int$unparse(n) || "! = " || int$unparse(factorial(n)))
except when negative:
stream$putl(po, "Integer must be positive")
when overflow:
stream$putl(po, "Overflow")
end
end
end start_up
factorial = proc (n: int) returns (int) signals (negative, overflow)
if n < 0 then signal negative end
if n = 0 then return(1) end
return(n*factorial(n-1))
resignal overflow
end factorial
Insufficient documentation for producing a reasonable example.
IDENTIFICATION DIVISION
PROGRAM-ID. SUM-OF-PRICES.
AUTHOR. TERENCE-PRATT.
SOURCE. PROGRAMMING-LANGUAGES-2ND-EDITION-1984
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT INP-DATA ASSIGN TO INPUT.
SELECT RESULT-FILE ASSIGN TO OUTPUT.
DATA DIVISION.
FILE SECTION.
FD INP-DATA LABEL RECORD IS OMITTED.
01 ITEM-PRICE
02 ITEM PICTURE X(30).
02 PRICE PICTURE 9999V99.
02 FILLER PICTURE X(44).
FD RESULT-FILE LABEL RECORD IS OMITTED.
01 RESULT-LINE PICTURE X(132).
WORKING-STORAGE SECTION.
77 TOT PICTURE 999999V99, VALUE 0, USAGE IS COMPUTATIONAL.
77 COUNT PCITURE 9999, VALUE 0, USAGE IS COMPUTATIONAL.
01 SUM-LINE.
02 FILLER VALUE ' SUM ='PICTURE X(12).
02 SUM-OUT PICTURE $$,$$$,$$9.99.
02 FILLER VALUE ' NO. OF ITEMS ='PICTURE X(21).
02 COUNT-OUT PICTURE ZZZ9.99.
01 ITEM-LINE.
02 ITEM-OUT PICTURE X(30).
02 PRICE-OUT PICTURE ZZZ9.99.
PROCEDURE DIVISION.
START.
OPEN INPUT INP-DATA AND OUTPUT RESULT-FILE.
READ-DATA.
READ INP-DATA AT END GO TO PRINT-LINE.
ADD PRICE TO TOT.
ADD 1 TO COUNT.
MOVE PRICE TO PRICE-OUT.
MOVE ITEM TO ITEM-OUT.
WRITE RESULT-LINE FROM ITEM-LINE.
GO TO READ-DATA.
PRINT-LINE.
MOVE TOT TO SUM-OUT.
MOVE COUNT TO COUNT-OUT.
WRITE RESULT-LINE FROM SUM-LINE.
CLOSE INP-DATA AND RESULT-FILE.
STOP RUN.
;; An example of array search from the common
;; lisp standard
(defun finder (obj vec start end)
(let ((range (- end start)))
(if (zerop range)
(if (eql obj (aref vec start))
obj
nil)
(let ((mid ( start (round (/ range 2)))))
(let ((obj2 (aref vec mid)))
(if (< obj obj2)
(finder obj vec start (- mid 1))
(if (> obj obj2)
(finder obj vec ( mid 1) end)
obj)))))))
// Solution to Hamming's problem in Clean, // generate an infinite sorted stream of numbers // of the form (2^n)*(3^m)*(5*p). From the examples // distributed with Concurrent Clean v1.2. Ham::[Int] Ham = y where y = [1:merge (merge (map ((*) 2) y) (map ((*) 3) y)) (map ((*) 5) y)] merge [] [] = [] merge f [] = f merge [] f = f merge f=:[a:b] g=:[c:d] | a<c = [a:merge b g] | a==c = merge f d | otherwise = [c: merge f d] Start::[Int] Start = take NrElements Ham NrElements :== 300 // Size of finite sample to take.
{ A small example monitor and process from Hansen's 1993 }
{ paper given at HOPL-II. }
type linebuffer =
monitor
var contents : line;
full : Boolean;
sender, receiver : queue;
procedure entry receive(var text : line);
begin
if not full then delay(receiver);
text := contents; full := false;
continue(sender);
end;
procedure entry send(text : line);
begin
if full then delay(sender);
contents := text; full := true;
continue(receiver);
end;
begin full := false;
end; { linebuffer }
type printerprocess =
process(buffer: linebuffer)
var param : ioparam;
text : line;
begin
param.operation := output;
cycle
buffer.receive(text);
repeat io(text,param,printdevice)
until param.status = complete;
end
end;
WITHOBJECT "CorelPhotoPaint.Automation.7"
.SetDocumentInfo 96, 96
.MaskSelectAll
.EditCopy
.ImagePapersize 192, 96, 0, 0, 5, 255, 255, 255, 0
.MaskInvert
.EditPasteIntoSelection
.MaskChannelAdd "Alpha 1"
.MaskBorder 4, 1
.ImageBCI -20, 0, 0
.EndColorEffect
.MaskChannelToMask 0, 0
offset% = 50
BEGIN DIALOG Dialog4 182, 79, "Corel SCRIPT Dialog"
SPINCONTROL 91, 12, 76, 18, offset%
TEXT 28, 17, 55, 11, "Offset amount:"
OKBUTTON 56, 50, 69, 21
END DIALOG
X = Dialog(Dialog4)
.EffectOffset 0, offset%, TRUE, 0
.MaskRemove
END WITHOBJECT
#!/bin/csh
# A simple csh script to find a command on
# the directories listed in the environment
# variable PATH, and print out information
# about it.
set cmd=$1
if ("$cmd" == "") then
echo "Usage: findcmd commandname"
exit 1
endif
set cnt=0
foreach dir ($path)
set check="$dir/$cmd"
if (-x "$check" && ! (-d "$check")) then
file $check
ls -ldg $check
set cnt=$cnt 1
endif
end
if ($cnt == 0) then
echo "Sorry, command $cmd not found."
exit 1
else
exit 0
endif
PHIL = *[ ...During n'th lifetime
THINK;
room!enter( );
fork(i)!pickup( );
fork((i 1) mod 5)!pickup;
EAT;
fork(i)!putdown( );
fork((i 1) mod 5)!putdown( );
room!exit( );
]
FORK = *[
phil(i)?pickup( ) -> phil(i)?putdown( );
[]
phil((i - 1) mod 5)?pickup( ) ->
phil((i - 1) mod 5)?putdown( );
ROOM = occupancy:integer; occupancy = 0;
*[(i:0..4)phil(i)?enter( ) ->
occupancy := occupancy 1;
[]
(i:0..4)phil(i)?exit( ) ->
occupancy := occupancy - 1;
MAIN = [room::ROOM || fork(i:0..4)::FORK ||
phil(i:0..4)::PHIL].
* A subroutine to draw 1-d chaos, from a
* sample program by Bruce Sherwood.
unit chaos
f: pop, rate $$ population and growth rate
i: n, TRIES=40, base=8
i: usecolor
f: h, s, v
calc usecolor := (zncolors >= 8 base)
palette zred,100,0,0,zwhite
if usecolor
loop n := 0,7 $$ make hues from blue to red
getrgb 240[1-(n 1)/8],100,100; h, s, v
palette base n,h,s,v
endloop
endif
color zwhite
do graph
color zred
loop rate := 2.7, 3.99, .01
calc pop := .1 $$ starting population
loop n := 1, TRIES
* New population is rate times current population
* times a resource-limiting factor (1-pop):
calc pop := rate*pop*(1-pop)
if usecolor
color base int(8(n-1)/TRIES)
elseif TRIES-n > 8
reloop
endif
gfill rate,pop;rate .01,pop .005
endloop
endloop
The syntax of Curry is complex, compact, and similar to that of Haskell. Each statement of a Curry program is an equation or predicate. Executing a Curry program consists of simplifying equations and expressions until a particular specified goal is reached or a particular solution is obtained. Primitive data types supported by Curry include booleans, integers, reals, chars, and strings. Aggregate and specialized data types include tuples, lists, functions, and constraints. Oddly enough, Curry uses the same comment syntax as Ada. The module construct serves to encapsulate libraries of functions, data types, and expressions. The module seems to be the only program structuring facility in Curry.
Like many functional languages, Curry supports a declarative I/O model. This kind of model basically represents input and output operations as expressions involving 'the World'.
Some of the advanced features of Curry are listed below.
As an academic project, implementations of Curry are available free. Documentation is available on the web, but almost exclusively in DVI format.
Several implementations of Curry exist. The most viable one seems to be PACS, the Portland Aachen Curry System. It is a compiler that translates Curry programs into various intermediate forms: Prolog or Java. Free downloads of PACS for UNIX systems are available from RWTH Aachen. Other Curry implementations are interpreters written in Prolog.
There has been a trend in the 1990s to try to integrate ideas from some of the most powerful computer programming research paradigms. Curry, like LEDA and NIAL, is an example of this trend.
-- quicksort using higher-order functions:
-- filter elements in a list (predefined as `filter'):
filter_ :: (a -> Bool) -> [a] -> [a];
filter_ _ [] = []
filter_ p (x:xs) = if p x then x : filter_ p xs
else filter_ p xs
qsort :: [Int] -> [Int]
qsort [] = []
qsort (x:l) = qsort (filter (< x) l) x : qsort (filter (>= x) l)
// A naive Quicksort in Dylan by Jon Sobel define method quicksort (data ::) => sorted-data ::
; if (empty?(data) | empty?(tail(data))) data; else collect(head(data), tail(data), #(), #()); end if; end method quicksort; define method collect (pivot, data ::
, left-side, right-side) => sorted-data ::
; case empty?(data) => concatenate(quicksort(left-side), pair(pivot, quicksort(right-side))); (pivot < head(data)) => collect(pivot, tail(data), left-side, pair(head(data), right-side)); otherwise => collect(pivot, tail(data), pair(head(data), left-side), right-side); end case; end method collect;
/* A simple class to maintain an int built up
* from prime factors. Adapted from examples
* in the Dynace Manual. */
defclass BuiltInt {
unsigned long iRunningValue;
class:
int cCntInstances;
};
cmeth gNew()
{
object obj;
obj = gNew(super);
cCntInstances += 1;
ivType *iv;
iv = ivPtr(obj);
runningValue = 1;
return obj;
}
imeth void addFactor(unsigned long fac)
{
iRunningValue *= fac;
return;
}
imeth unsigned long getValue() { return iRunningValue; }
imeth object gDeepDispose, gDispose ()
{
cCntInstances -= 1;
gDispose(super self);
return 0;
}
class ACCOUNT feature
balance: INTEGER;
owner: PERSON;
minimum_balance: INTEGER is 1000
open (who: PERSON) is
-- Assign the account to owner who.
do
owner := who
end
deposit (sum: INTEGER) is
-- Deposit sum into the account.
do
add (sum)
end
withdraw (sum: INTEGER) is
-- Withdraw sum from the account.
do
add (-sum)
end
may_withdraw (sum: INTEGER): BOOLEAN is
-- Is there enough money to withdraw sum?
do
Result := (balance >= sum + minimum_balance)
end
feature {NONE}
add (sum: INTEGER) is
-- Add sum to the balance.
do
balance := balance + sum
end
end -- class ACCOUNT
;; Simple Elisp example
(defconst date-pattern-1
"\\(1?[0-9]\\)/\\([123]?[0-9]\\)/\\([0-9][0-9]\\)"
"Regexp for one style of data string")
(defun replace-all-dates ()
"Replace 1/27/93 dates with 27-1-93 dates"
(interactive)
(let ((mcount 0))
(while (re-search-forward date-pattern-1 nil t)
(replace-match "\\2-\\1-\\3" nil nil)
(setq mcount (+ 1 mcount)))
(message (format "Replaced %d dates" mcount)))
)
-module(sort).
-export([sort/1]).
sort([]) -> [];
sort([Pivot|Rest]) ->
{Smaller, Bigger} = split(Pivot, Rest),
lists:append(sort(Smaller), [Pivot|sort(Bigger)]).
split(Pivot, L) ->
split(Pivot, L, [], []).
split(Pivot, [], Smaller, Bigger) ->
{Smaller, Bigger};
split(Pivot, [Hd|Tl], Smaller, Bigger) when Hd < Pivot ->
split(Pivot, Tl, [Hd|Smaller], Bigger);
split(Pivot, [Hd|Tl], Smaller, Bigger) when Hd >= Pivot ->
split(Pivot, T, Smaller, [Hd|Bigger]).
Alternative version using Erlang 4.4 features:
-module(sort).
-export([sort/1]).
sort([Pivot|T]) ->
sort([ X || X <- T, X < Pivot]) ++ [Pivot] ++
sort([ X || X <- T, X >= Pivot]);
sort([]) -> [].
MODULE Lambda.
CONSTRUCT Person/0.
FUNCTION Jane, Mary, John: One -> Person.
FUNCTION Mother : Person * Person -> Boolean.
Mother(x,y) =>
x=Jane & y=Mary.
FUNCTION Wife : Person * Person -> Boolean.
Wife(x,y) =>
x=John & y=Jane.
FUNCTION PrimitiveRel : (Person * Person -> Boolean) -> Boolean.
PrimitiveRel(r) =>
r=Mother \/ r=Wife.
FUNCTION Rel : (Person * Person -> Boolean) -> Boolean.
Rel(r) =>
PrimitiveRel(r) \/
(SOME [r1,r2]
(r = LAMBDA [u] (SOME [z] (r1(Fst(u),z) & r2(z,Snd(u)))) &
PrimitiveRel(r1) & PrimitiveRel(r2))).
module AVERAGE:
input INCREMENT_AVERAGE(integer);
output AVERAGE_VALUE(integer);
var TOTAL := 0, NUMBER := 0, : integer in
every immediate INCREMENT_AVERAGE do
TOTAL := TOTAL + ? INCREMENT_AVERAGE;
NUMBER := NUMBER + 1;
emit AVERAGE_VALUE (TOTAL / NUMBER)
end
end.
-- Prime sieve benchmark, adapted from Euphoria 2.0beta demos
constant ON = 1, OFF = 0, SIZE = 5000, BATCH = 20
function sieve()
sequence flags
integer prime, start, count, still_prime
count = 0
flags = repeat(ON, SIZE)
for i = 1 to SIZE do
still_prime = flags[i]
if still_prime then
prime = 2 * i
prime = prime + 1
start = prime + i
for k = start to SIZE by prime do
flags[k] = OFF
end for
count = count + 1
end if
end for
return count
end function
atom t, cycles, p
cycles = 0
t = time()
while time() < t + 30 do -- test for 30 seconds
for iter = 1 to BATCH do
p = sieve()
end for
cycles = cycles + BATCH
end while
t = time() - t
printf(1, "%6.1f sieves per second\n", cycles / t)
DEFINE PROCEDURE ''DIVIDE'' [DIVIDEND, DIVISOR]:
BLOCK 0: BEGIN
IF DIVISOR < 1, THEN: QUIT BLOCK 0;
CELL(0) <= DIVIDEND;
LOOP AT MOST DIVIDEND TIMES:
BLOCK 1: BEGIN
IF CELL(0) < DIVISOR, THEN: QUIT BLOCK 0;
CELL(0) <= MINUS[CELL(0), DIVISOR];
OUTPUT <= OUTPUT + 1;
BLOCK 1: END;
BLOCK0: END.
DEFINE PROCEDURE ''PERFECT?'' [N]:
BLOCK 0: BEGIN
CELL(0) <= 0;
CELL(1) <= 0;
LOOP DIVIDE [N,2] TIMES:
BLOCK 1 BEGIN:
CELL(1) <= CELL(1) + 1;
IF REMAINDER[N,CELL(1)] = 0, THEN: CELL <= CELL(0) + CELL(1);
BLOCK 1 END;
IF CELL(0) = N THEN: OUTPUT <= YES;
BLOCK 0: END.
C FORMAC program to find the symbolic roots of some
C quadratic equations. By J. Sammet from the HOPL-II
C paper on the history of FORMAC, typos corrected.
SYMARG
ATOMIC X,Y,K
DIMENSION CASE(3), X1(3), x2(3)
LET CASE(1) = X**2 + 2*X*(Y+1) + (Y+1)**2
LET CASE(2) = 2 * X**2 - 4*X
LET CASE(3) = 3*X**2 + K*(X+X**2+1) +4
N=3
DO 88 I = 1,N
LET RVEXPR = EXPAND CASE(I)
LET A = COEFF RVEXPR,X**2
LET B = COEFF RVEXPR,X
LET C = COEFF RVEXPR,X**0
LET DISCRM = EXPAND B**2 - 4*A*C
LET X1(I) = EXPAND (-B + DISCRM**(1/2))/(2*A)
LET X2(I) = EXPAND (-B - DISCRM**(1/2))/(2*A)
88 CONTINUE
FMCDMP
STOP
END
\ Forth implementation of Newton's method for finding
\ roots, simplified. (c) Copyright 1994 Everett F. Carter.
: z1 ( i -- ) ( f: -- z1 )
z F@ xn{ SWAP } F@ F-
;
: Newton ( i -- ) ( f: e d p -- e d p )
\ calculate new D
DUP z1 FROT F* FOVER F+
\ calculate new P
FSWAP DUP z1 F* dif{ OVER } F@ F+
\ calculate new E
FROT z1 FABS F* FOVER FABS F+
\ restore stack order
FROT FROT
;
: FNewt ( &xn &dif n -- ) ( f: z -- e d p)
>R
& dif{ &!
& xn{ &!
R>
z F! 0.0e0 0.0e0 0.0e0
0 DO
I Newton
LOOP
;
PROGRAM Rad
! Simple FORTRAN program
REAL P,R,C
IF (.NOT. (R = 0.0)) THEN
P = 3.1415926
R = 2.5
C = P * R
PRINT *, "C = ", C
END IF
END
# Mergesort from the Berkeley FP manual
{ mergeSort | merge }
{merge atEnd @ mergeHelper @ [[], fixLists]}
# convert atomic args into sequences
{fixLists &(atom -> [id] ; id)}
# Merge until one or both input seqs are empty
{mergeHelper (while and @ &(not @null) @ 2
(firstIsSmaller -> takeFirst; takeSecond))}
# Find seq with smaller first element
{firstIsSmaller < @ [1 @ 1 @ 2, 1 @ 2 @ 2]}
# Take the first element of the first seq
{takeFirst [apndr @ [1,1 @ 1 @ 2], [tl @ 1 @ 2, 2 @ 2]]}
# Take the first element of the second seq
{takeSecond [apndr @ [1,1 @ 2 @ 2], [1 @ 2, tl @ 2 @ 2]]}
# Handle remaining nonempty seq
{atEnd (firstIsNull -> concat @ [1,2 @ 2];
concat @ [1,1 @ 2])}
{firstIsNull null @ 1 @ 2}
# apply the function
mergeSort : <0 3 -2 1 11 8 -22 -33>
% This is one of the example programs
% included with the V1.4 distribution.
MODULE EightQueens.
IMPORT Lists.
PREDICATE Queen : List(Integer).
Queen(x) <-
Safe(x) &
Permutation([1,2,3,4,5,6,7,8], x).
PREDICATE Safe : List(Integer).
DELAY Safe(x) UNTIL NONVAR(x).
Safe([]).
Safe([x|y]) <-
NoDiagonal(x,1,y) &
Safe(y).
PREDICATE NoDiagonal : Integer * Integer * List(Integer).
DELAY NoDiagonal(_,_,z) UNTIL NONVAR(z).
NoDiagonal(_,_,[]).
NoDiagonal(x,y,[z|w]) <-
y ~= Abs(z - x) &
NoDiagonal(x,y+1,w).
BARBERS STORAGE 20
GENERATE RVEXPO(1,1.5)
QUEUE CUSTOMS
ENTER BARBERS
UNLINK MIN BARBERS,BARBGO,1,(UTIL)PL
LINK CUSTOMS
CLEAVE AVANCE .5
TERMINATE
BARBGEN GENERATE ,,,20,5,1PH,1PL 20 BARBERS
ASSIGN IBARB,N(BARBGEN),,PH
LINK BARBERS,FIFO
BARBGO SEIZE PH(IBARB)
ADVANCE RVEXPO(1,30)
RELEASE PH(IBARB)
LEAVE BARBERS
ASSIGN BUSE,FR(PH(IBARB)),,PL
UNLINK CUSTOMS,CLEAVE,1
LINK BARBERS,FIFO
GENERATE 60*10
TERMINATE 1
START 1
-- Stable quicksort in Haskell by Lennart Augustsson
--
module QSort(sortLe, sort) where
sortLe :: (a -> a -> Bool) -> [a] -> [a]
sortLe le l = qsort le l []
sort :: (Ord a) => [a] -> [a]
sort l = qsort (<=) l []
-- qsort is stable and does not concatenate.
qsort le [] r = r
qsort le [x] r = x:r
qsort le (x:xs) r = qpart le x xs [] [] r
-- qpart partitions and sorts the sublists
qpart le x [] rlt rge r =
-- rlt and rge are in reverse order and must be sorted with an
-- anti-stable sorting
rqsort le rlt (x:rqsort le rge r)
qpart le x (y:ys) rlt rge r =
if le x y then
qpart le x ys rlt (y:rge) r
else
qpart le x ys (y:rlt) rge r
use lists, functions, products;
type rose_tree alpha == alpha # list(rose_tree alpha);
dec bf_list : rose_tree alpha -> list alpha;
--- bf_list t <= [t].
iterate (concat o map snd).
front_with (/= []).
concat.
map fst;
/* A program to count words in input files
* (from examples at the ICI web site)
*/
static count_tokens(in)
{
auto count;
count = 0;
while (gettoken(in)) ++count;
return count;
}
if (argc < 2) printf("%d\n", count_tokens(stdin));
else
{
auto f, fn, total;
total = 0;
forall (fn in interval(argv, 1))
{
if (fn == "-")
count = count_tokens(stdin);
else
{
auto count;
count = count_tokens(f = fopen(fn));
close(f);
}
printf("%s %d\n", fn, count);
total += count;
}
if (argc > 2) printf("Total %d\n", total);
}
# Example from New Mexico Tech Icon
# tutorial by John Shipman
procedure Quadratic_Roots ( a, b, c )
# Generates the real roots of ax^2+bx+c=0.
local d # Discriminant
d := b ^ 2 - 4.0 * a * c; # Compute the discriminant
if d > 0 then
{ #-- Two roots
suspend ( - b + sqrt ( d ) ) / ( 2.0 * a );
suspend ( - b - sqrt ( d ) ) / ( 2.0 * a );
} #-- Two roots
else if d = 0 then
suspend - b / ( 2.0 * a );
fail; # No more roots
end
procedure main ()
local root # Holds each root generated by the solver
local count # Counts the number of roots returned
count := 0;
every root := Quadratic_Roots ( 1, -4, 3 ) do
{ #-- The braces {} group the next two statements together
write ( "One solution is: x = ", root );
count +:= 1; # Count the roots generated
}
write ( "The number of solutions was ", count );
end
INTERCAL's main advantage over other programming languages is its simplicity. It has few capabilities, and thus there are few restrictions to be kept in mind. Since it is an exceedingly easy language to learn, one might expect it would be a good language for initiating novice programmers. Perhaps surprising, than [sic], is the fact that it would be more likely to initiate the novice into a search for another line of work.
PLEASE NOTE THIS PROGRAM PRINTS A LIST
PLEASE DO NOT ASSUME THAT THE NUMBERS ARE COMPOSITE
PLEASE NOTE THIS PROGRAM WAS SWIPED FROM LOUIS HOWELL
DO READ OUT #2
DO .10 <- #1
PLEASE COME FROM (23)
DO .11 <- !10$#1'~'#32767$#1'
DO .12 <- #1
PLEASE COME FROM (16)
DO .13 <- !12$#1'~'#32767$#1'
DO .1 <- .11
DO .2 <- .13
DO (2030) NEXT
DO (11) NEXT
(15) DO (13) NEXT
(13) DO .3 <- "?!4~.4'$#2"~#3
DO (14) NEXT
PLEASE FORGET #1
DO .1 <- .12
DO (1020) NEXT
(16) DO .12 <- .1
(12) DO .3 <- '?.2$.3'~'#0$#65535'
DO .3 <- '?"'&"!2~.3'~'"?'?.3~.3'$#32768"~"#0$#65535"'"$
".3~.3"'~#1"$#2'~#3
(14) PLEASE RESUME .3
(11) DO (12) NEXT
DO FORGET #1
PLEASE READ OUT .11
DO COME FROM (15)
DO .1 <- .10
DO (1020) NEXT
DO .10 <- .1
(23) DO (21) NEXT
(22) PLEASE RESUME "?!10~#32768'$#2"~#3
(21) DO (22) NEXT
DO FORGET #1
PLEASE GIVE UP
(2010) PLEASE ABSTAIN FROM (2004)
(2000) PLEASE STASH .2
DO .2 <- #1
DO (2001) NEXT
(2001) PLEASE FORGET #1
DO .1 <- '?.1$.2'~'#0$#65535'
DO (2002) NEXT
DO .2 <- !2$#0'~'#32767$#1'
DO (2001) NEXT
(2003) PLEASE RESUME "?!1~.2'$#1"~#3
(2002) DO (2003) NEXT
PLEASE RETRIEVE .2
(2004) PLEASE RESUME #2
PLEASE DO REINSTATE (2004)
PLEASE RESUME '?"!1~.1'~#1"$#2'~#6
(2020) PLEASE STASH .2 + .3
DO (1021) NEXT
(2030) DO STASH .1 + .5
DO .3 <- #0
DO .5 <- '?"!2~.2'~#1"$#1'~#3
PLEASE DO (2031) NEXT
DO .4 <- #1
PLEASE DO (2033) NEXT
(2033) DO FORGET #1
DO .5 <- '?".2~#32768"$#2'~#3
DO (2032) NEXT
DO .2 <- !2$#0'~'#32767$#1'
PLEASE DO .4 <- !4$#0'~'#32767$#1'
DO (2033) NEXT
(2032) DO (1001) NEXT
(2036) PLEASE FORGET #1
DO .5 <- '?.1$.2'~'#0$#65535'
DO .5 <- '?"'&"!2~.5'~'"?'?.5~.5'$#32768"~"#0$#65535"'"$
".5~.5"'~#1"$#2'~#3
DO (2034) NEXT
DO .5 <- .3
DO (1010) NEXT
PLEASE DO .1 <- .3
DO .3 <- 'V.4$.5'~'#0$#65535'
DO (2035) NEXT
(2034) PLEASE DO (1001) NEXT
(2035) DO FORGET #1
DO .5 <- "?'.4~#1'$#2"~#3
DO (2031) NEXT
DO .2 <- .2~#65534
DO .4 <- .4~#65534
PLEASE DO (2036) NEXT
(2031) DO (1001) NEXT
PLEASE DO .4 <- .1
PLEASE RETRIEVE .1 + .5
PLEASE RESUME #2
NB. continued fraction representation of Pi:
rf=. % @ (1&|)
Pi=. 1p1
[v=. <. rf ^: (i.10) Pi
3 7 15 1 292 1 1 1 2 1
(+%) /\ 5{. v
3 3.14286 3.14151 3.14159 3.14159
import java.awt.*;
import java.util.*;
public class Showtime extends Frame implements Runnable {
Button quitBtn;
Label timeLbl;
Thread tthread;
public Showtime() {
super("Java Showtime");
setLayout(new FlowLayout());
quitBtn = new Button("Quit");
timeLbl = new Label((new Date()).toString());
add(quitBtn); add(timeLbl);
pack();
show();
tthread = new Thread(this);
tthread.run();
}
public boolean action(Event evt, Object what) {
if (evt.target == quitBtn) {
tthread.stop();
System.exit(0);
}
return super.action(evt,what);
}
public void run() {
while(true) {
try { Thread.sleep(10000); }
catch (Exception e) { }
timeLbl.setText((new Date()).toString());
}
}
public static void main(String [] argv) {
Showtime st = new Showtime();
}
}
<script language=javascript>
sub chkrange(elem,minval,maxval) {
if (elem.value < minval ||
elem.value > maxval)
{
alert("Value of " + elem.name + " is out of range!");
}
}
</script>
<input type=button onclick="chkrange(myform.numitem,1,10);">
{ Table data structure, adapted from an example
in "Multiparadigm Data Structures in Leda"
by Tim Budd, 1993
Assumes the list data structure is already defined. }
class Association [X, Y : equality] of equality[Association];
var
key : X;
value : Y;
function equals(argValue : Association[X, Y])->boolean;
begin
return key = argValue.key;
end;
end;
class Table [X, Y : equality] { of equality[Association] };
var
data : List[Association[X, Y]];
function add (newKey : X, newValue : Y);
begin
if ~ defined(data) then
data := List[Association[X, Y]]();
data.add(Association[X, Y](newKey, newValue));
end;
function onEach (theFun : function(X, Y));
begin
if defined(data) then
data.onEach(function (item : Association[X, Y]);
begin
theFun(item.key, item.value);
end);
end;
function items (byRef key : X, byRef value : Y)->relation;
var
element : Association[X, Y];
begin
return defined(data)
& data.items(element)
& unify[X](key, element.key)
& unify[Y](value, element.value);
end;
function includesKey (key : X)->boolean;
var
value : Y;
begin
if items(key, value) then
return true;
return false;
end;
function at (key : X)->Y;
var
value : Y;
begin
if items(key, value) then
return value;
return NIL;
end;
function atPut (key : X, value : Y);
var
element : Association[X, Y];
begin
if defined(data) & data.items(element) & element.key = key then
element.value := value
else
add(key, value);
end;
end;
global(sieve)?
global(limit)?
main :-
write("N=?"), read_token(limit & int),
next_prime(2), nl.
remove_multiples(P,M) :-
cond(M < limit,
(sieve.M <-multiple_of(P),remove_multiples(P,M+P))
).
next_prime(P) :- P < limit, !, SP=sieve.P,
( SP=prime(P),
!,
write(P,' '),
remove_multiples(P,2*P)
;
succeed
),
next_prime(P+1).
next_prime(P).
# A simple program to sum up some numbers
# presented on the command line, from
# Bob Pike's forthcoming book on Limbo.
implement Sum;
include "sys.m";
sys: Sys;
include "draw.m";
Sum: module
{
init: fn(context: ref Draw->Context, argl: list of string);
};
init(context: ref Draw->Context, argl: list of string)
{
sys = load Sys Sys->PATH;
argl = tl argl; # ignore command name
if(len argl == 0){
sys->print("usage: sum numbers....\n");
return;
}
sum := 0.0;
while(argl != nil){
arg := hd argl;
sys->print("%s", arg);
sum += real arg;
argl = tl argl;
if(argl != nil)
sys->print(" + ");
}
sys->print(" = %g\n", sum);
}
;; Simple factorial routine
;; (until I get a better example written)
(defun fact1 (num)
(cond ((not (integerp num)) nil)
((<= num 1) 1)
(t (* num (fact1 (- num 1)))))
)
; Recursive procedure to line, fractalized
to DrawFractalLine :level :length
ifelse :level < 1 [
fd :length] [
DrawFractalLine (sum -1 :level) (quotient :length 3.00)
left 60
DrawFractalLine (sum -1 :level) (quotient :length 3.00)
right 120
DrawFractalLine (sum -1 :level) (quotient :length 3.00)
left 60
DrawFractalLine (sum -1 :level) (quotient :length 3.00)
]
end
; procedure to clear screen and position turtle
to SetupTurtle
cs setpos [-160 -10] right 60 clean
end
; setup turtle then draw Koch's snowflake(5)
SetupTurtle
setpensize [2 2]
repeat 3 [DrawFractalLine 5 330 right 120]
' Find agents owned by the current user
' and remove them (Adapted from examples at
' www.lotus.com)
Dim session As New NotesSession
Dim db As NotesDatabase
Dim agentArray(1 To 10) As NotesAgent
Dim count as Integer
Dim answer as string
count = 0
Set db = session.CurrentDatabase
Forall a In db.Agents
If ( a.Owner = session.UserName ) Then
Set agentArray(count) = a
count = count + 1
If (count > 10) Then
Exit Forall
End If
End If
End Forall
answer = Inputbox$( "You have " & count & " agents. Delete them?" )
If (answer = "y") Or (answer = "yes") Then
Forall a in agentArray
Call a.Remove
End Foreall
End If
-- Simple Lua program that implements the
-- bisection method for solving non-linear equations
function bisect(f,a,b,fa,fb)
write(n," a=",a," fa=",fa," b=",b," fb=",fb,"\n")
local c=(a+b)/2
if abs(a-b) < delta then return c end
n=n+1
local fc=f(c)
if fa*fc < 0 then
return bisect(f,a,c,fa,fc)
else
return bisect(f,c,b,fc,fb)
end
end
-- find root of f in the inverval [a,b].
-- bisection requires that f(a)*f(b) < 0
function solve(f,a,b)
delta=1e-6 -- tolerance
n=0
local z=bisect(f,a,b,f(a),f(b))
write(format("after %d steps, root is %.10g\n",n,z))
end
-- test the bisection code with
-- a function: x^3 - x - 1
function f(x)
return x*x*x - x - 1
end
solve(f,1,2)
h
where
h = 1 fby merge(merge(2 * h, 3 * h), 5 * h);
merge(x,y) = if xx <= yy then xx else yy fi
where
xx = x upon xx <= yy;
yy = y upon yy <= xx;
end;
end;
produce := procedure();
seq := ["S"];
rhs := ["(", "S", ")", "S"];
i := 1;
repeat
if Random(1, 10) gt 7 then
Insert(~seq, i, i, rhs);
else
Remove(~seq, i);
end if;
print #seq gt 0 select &*seq else "eps";
i := Position(seq, "S");
until i eq 0;
print "Length:", #seq;
end procedure
(* RandomWalk example from Maeder, 1990 *)
RandomWalk::usage = "RandomWalk[n] plots a random walk of length n"
RandomWalk[n_Integer] :=
Block[{loc = {0.0, 0.0}, dir, points= Table[0, {n+1}], range = N[{0, 2 Pi}]},
points[[1]] = loc;
Do[
dir = Random[Real, range];
loc += {Cos[dir], Sin[dir]};
points[[i]] = loc,
{i, 2, n+1}];
Show[ Graphics[{Point[{0,0}], Line[points]}],
Framed -> True, AspectRation -> Automatic]
]
/* the Voting example from the Mawl 2.1 Tutorial */
typedef { string name, int nVotes } vote;
static [ vote ] tally = [ ];
static int total = 0;
session vote
{
auto form { [ vote ] tally, int total, string castvote } showvote;
showvote.put( { tally, total, "Vote" } );
}
subsession void AddVote(string name)
{
++total;
auto int i;
for (i = 0; i < tally.length(); ++i)
if (tally[i].name == name) {
tally[i].nVotes++;
return;
}
tally.append( { name, 1 } );
}
session Vote
{
auto form void -> { string name } getName;
AddVote( getName.put().name );
}
% An example of finding primes using a sieve
% (adapted from a logic programming benchmark in mercury)
:- interface.
:- import_module list, int.
:- implementation.
:- pred primes(int, list(int)).
:- mode primes(in, out) is det.
:- pred integers(int, int, list(int)).
:- mode integers(in, in, out) is det.
:- pred sift(list(int), list(int)).
:- mode sift(in, out) is det.
:- pred remove(int, list(int), list(int)).
:- mode remove(in, in, out) is det.
primes(Limit, Ps) :- integers(2, Limit, Is), sift(Is, Ps).
integers(Low, High, Result) :-
( Low =< High ->
M is Low + 1,
Result = [Low | Rest], integers(M, High, Rest)
;
Result = []
).
sift([], []).
sift([I | Is], [I | Ps]) :- remove(I, Is, New), sift(New, Ps).
remove(_P, [], []).
remove(P, [I | Is], Result) :-
M is I mod P,
( M = 0 ->
Result = Nis, remove(P, Is, Nis)
;
Result = [I | Nis], remove(P, Is, Nis)
).
|| Sorting with the comparison function as a parameter
|| (adapted from code example by Simon Thompson)
sortG :: (* -> * -> bool) -> [*] -> [*]
sortG comp (a:x)
= sortG comp smaller ++ [a] ++ sortG comp larger
where
smaller = [ b | b<-x ; comp b a ]
larger = [ b | b<-x ; comp a b ]
|| Example Use
CompInt :: (* -> * -> bool)
CompInt m n = (m < n)
SortG CompInt [3,5,0,12,8,43,7]
fun sort nil = nil : int list
| sort(h::t) = let
fun insert(i,nil) = [i]
| insert(i,h::t) = if i>h then i::h::t else
h::insert(i,t)
in insert(h, sort t) end;
fun mean l = let
fun sl(nil ,sum,len) = sum div len
| sl(h::t,sum,len) = sl(t,sum+h,len+h)
in sl(l,0,0) end;
mean(sort [2,3,5,7,11,13] @ [6,14,28] )
MODULE Push EXPORTS Main;
IMPORT Trestle, VBT, TextVBT, RigidVBT, ButtonVBT, BorderedVBT, HVSplit,
Axis;
action of button when pushed
PROCEDURE QuitAction (self: ButtonVBT.T; READONLY cd: VBT.MouseRec) =
BEGIN
Trestle.Delete(main); (* NB. "main" is visible here. *)
END QuitAction;
CONST
horz = 30.0; (* horizontal size "hello" window *)
vert = 10.0; (* vertical size of "hello" window *)
VAR
hello := RigidVBT.FromHV(TextVBT.New("Hello World"), horz, vert);
quit := ButtonVBT.New(ch := TextVBT.New("Quit"), action := QuitAction);
main := HVSplit.Cons(Axis.T.Ver, hello, BorderedVBT.New(quit));
BEGIN
Trestle.Install(main);
Trestle.AwaitDelete(main);
END Push.
MODULE AlphaRandom;
(* Randomize the alphabet, and show how to use the module Shuffle *)
(* John Andrea, 1992 *)
FROM InOut IMPORT WriteLn, WriteString;
FROM Shuffle IMPORT Deck, Create, Next, Reset;
VAR
d :Deck;
i, j, min, max, n :CARDINAL;
BEGIN
min := ORD( 'a' );
max := ORD( 'z' );
n := max - min + 1;
Create( d, min, max );
FOR i := 1 TO 10 DO
WriteString( 'random alphabet = ' );
FOR j := 1 TO n DO
WriteString( CHR( Next( d ) ) );
END;
WriteLn;
Reset( d );
END;
END AlphaRandom.
; EXAMPLE FROM UC DAVIS LEXICON ;PROGRAM TO CREATE SORTED DICTIONARY READ !,"ENTER NEXT TERM (NULL TO QUIT): ",TERM GOTO:TERM="" LIST READ !,"ENTER ONE LINE DEFINITION: ",DEF SET ^WORD(TERM)=DEF GOTO LEXICON LIST READ !,"WOULD YOU LIKE TERMS LISTED (Y/N)?",YESNO QUIT:YESNO'?1"Y".E SET X="" ;TO GO TO PRINTER ADD 'OPEN 1 USE 1' FOR I=1:1 SET Y=$ORDER(^WORD(X)),X=Y QUIT:X="" WRITE !,Y,?15,^WORD(Y)
% Fits a line to a set of of points %
% using a simple regression algorithm, %
% return line and goodness of fit. %
% (from code examples with NESL 3.1) %
function line_fit(x, y) =
let
n = float(#x);
xa = sum(x)/n;
ya = sum(y)/n;
Stt = sum({(x - xa)^2: x});
b = sum({(x - xa)*y: x; y})/Stt;
a = ya - xa*b;
chi2 = sum({(y-a-b*x)^2: x; y});
siga = sqrt((1.0/n + xa^2/Stt)*chi2/n);
sigb = sqrt((1.0/Stt)*chi2/n)
in
(a, b, siga, sigb) $
# A routine to look for HTML tags in a
# file (from the AboutNial page at NIAL Systems)
findtagtext IS OPERATION Text {
Hdposns := `< findall Text;
Tlposns := `> findall Text;
Lengths := Tlposns - Hdposns + 1;
Tags := Hdposns EACHBOTH + EACH tell Lengths EACHLEFT choose Text;
Hdposns Tags }
test is op fnm {
findtagtext readfield fnm 0 (filelength fnm) }
Posns Tags := test "intro.htm;
(* Oberon module to read in numbers *)
(* average them. *)
MODULE Stats;
IMPORT Texts, Oberon;
TYPE
Stat* = POINTER TO StatRec;
StatRec *= RECORD
count: LONGINT;
total: REAL;
END;
PROCEDURE (s: Stat) Add* (REAL val);
VAR this: Stat;
BEGIN this := s;
this.total := this.total + val;
this.count := this.count + 1;
END Add;
PROCEDURE (s: Stat) Reset*;
VAR this: Stat;
BEGIN this := s;
this.total := 0.0;
this.count := 0;
END Reset;
PROCEDURE (s: Stat) IsValid*: BOOLEAN;
VAR this: Stat;
BEGIN this := s;
RETURN (this.count > 0);
END Reset;
PROCEDURE (s: Stat) Average*: REAL;
VAR this: Stat;
BEGIN this := s;
IF this.IsValid^() THEN
RETURN 0.0
ELSE
RETURN (this.total / this.count)
END Average;
END Stats;
/* still need an example here */
Server side:
(* A server for computing factorials. *)
module FactServer;
let fact =
net_export("fact","",
{ m =>
meth(s,n)
if n is 0 then 1 else n * s.m(n-1) end
end
});
Client side:
module FactClient;
let fact = net_import("fact","");
fact.m(13);
-- Pipelined parallel sort in occam
--(from Pountain and May, A Tutorial
-- Introduction to Occam Programming)
VAL numbers IS 100 :
[numbers + 1] CHAN OF INT pipe:
PAR
PAR i = 0 FOR numbers
input IS pipe[i] :
output IS pipe[i+1] :
INT highest :
SEQ
input ? highest
SEQ j = 0 FOR numbers - 1
INT next:
SEQ
input ? next
IF
next <= highest
output ! highest
next > highest
SEQ
output ! highest
highest := next
SEQ i = 0 FOR numbers -- get unsorted
INT unsortednumber : -- numbers
SEQ
input ? unsortednumber
pipe[0] ! unsortednumber
SEQ i = 0 FOR numbers -- dump sorted
INT sortednumber : -- numbers
SEQ
pipe[numbers] ? sortednumber
output ! sortednumber
; An OPS5 program that implements a model of
; rock climbers, from exercise solutions of
; "Expert Systems Programming in OPS5"
(literalize rock-climber
age ; young or old
style ; timid or bold
)
(p old-not-bold
(rock-climber ^age old ^style <> bold)
--->
(write (crlf) that is plausible))
(p bold-not-old
(rock-climber ^age <> old ^style bold)
--->
(write (crlf) that is quite possible))
(p error::old-and-bold
(rock-climber ^age old ^style bold)
--->
(write (crlf) There are no old, bold rock climbers))
(make rock-climber ^age young ^style bold)
# An example object from the paper
# "Experiences with the Orca Programming Language"
# by Bal and Wilson
OBJECT IMPLEMENTATION buffer;
CONST MAXSIZE = 10; # Maximum size of the buffer
# Local state of the object:
buf:ARRAY[integer 0..MAXSIZE-1] OF integer; # the buffer itself
in, out: integer; # index of next element to put/get
size: integer; # current size
OPERATION put(x: integer);
BEGIN
GUARD size ! MAXSIZE DO # blocks until there is room
buf[in] := x; # store element
in := (in + 1) % MAXSIZE; # bump input index
size +:= 1; # increment size
OD;
END;
OPERATION get(x: OUT integer);
BEGIN
GUARD size ? 0 DO # blocks while buffer is empty
x := buf[out]; # retrieve element
out := (out + 1) % MAXSIZE; # bump output index
size -:= 1; # decrement size
OD;
END;
END;
local
proc {AndThen BP1 BP2 ?B}
case {BP1} then
case {BP2} then B = true else B = false end
else B = false end
end
in proc {BinaryTree T ?B}
case T
of nil then B = true
[] tree(K V T1 T2) then
{AndThen proc {$ B1}{BinaryTree T1 B1} end
proc {$ B2}{BinaryTree T2 B2} end
B}
else B = false end
end
end
{ Sort program adapted from "Intermediate Pascal" }
{ by Joe Dorward. Illustrates arrays and types. }
program sort_array(input,output);
const
max = 9;
type
integer_array = array[1..max] of integer;
var
I, J, K, swaps, temp : integer;
test_array : integer_array;
begin
test_array[1] := 4; test_array[2] := 7; test_array[3] := 9;
test_array[4] := 3; test_array[5] := 15; test_array[6] := 2;
test_array[7] := 08; test_array[8] := 05; test_array[9] := 12;
writeln(' *** Initial Array ***');
writeln(' --- --- --- --- --- --- --- --- --- ');
for I := 1 to (max-1) do
write('|',test_array[I]:2,' ');
writeln('|',test_array[max]:2,' |');
for I := 1 to max do
for J := (I 1) to max do { set J to start one ahead of I }
if test_array[J] < test_array[I] then
begin
swaps := swaps 1;
temp := test_array[J];
test_array[J] := test_array[I];
test_array[I] := temp;
writeln;
writeln('* * Condition After ',swaps:1,' swaps * *');
writeln(' --- --- --- --- --- --- --- --- --- ');
for K := 1 to (max-1) do
write('|',test_array[K]:2,' ');
write('|',test_array[max]:2,' |');
end;
writeln(' * Sorting Complete *');
end.
#!/usr/bin/perl
# Simple program to extract column 3 from a file
# and total up the numbers.
$total = 0;
sub sumcolumn {
my $col = shift;
my $lin = shift;
my @fields;
if ($lin) {
@fields = split(/:/,$lin);
$total = $fields[2];
}
}
while (<>) {
sumcolumn(3,$_);
}
print "Total of column 3 is $total\n";
<?
mysql_connect("localhost","","") or die("Unable to connect to SQL server");
@mysql_select_db("php3") or die("Unable to select database");
$result = mysql_query("select * from customerTable limit 100");
?>
<table border="1">
<tr>
<?
while ($field=mysql_fetch_field($result)) {
echo "<th>";
echo "$field->name";
echo "</th>";
}
echo "</tr>";
while ($row = mysql_fetch_row($result)) {
echo "<tr>";
for ($i=0; $i<mysql_num_fields($result); $i ) {
echo "<td>";
echo "$row[$i]";
echo "</td>";
}
echo "</tr>\n";
}
echo "</table>";
The example below implements the Sieve of Erastosthenes (from the examples shipped with Pict 4.1).
now (reset checks)
def interval (min:Int max:Int):(List Int) =
if (>> min max) then nil else (cons min (interval (inc min) max))
def sieve (max:Int):(List Int) = (
def again (l:(List Int)):(List Int) =
if (null l) then
nil
else
(val n = (car l)
if (>> (* n n) max) then l
else (cons n (again (list.filter #Int l \(x) = (<> (mod x n) 0)))))
(again (interval 2 max))
)
def prPrime (idx:Int x:Int):[] =
if (== (mod idx 10) 9) then ((int.pr x); (nl))
else ((int.pr x); (pr " "))
(list.itApply (sieve 4000) prPrime);
// This program implements a fifo that can be used to send
// data between two threads. (From the Pike 0.6 manual, sec 10)
inherit Thread.Condition : r_cond;
inherit Thread.Condition: w_cond;
inherit Thread.Mutex: lock;
mixed *buffer = allocate(128);
int r_ptr, w_ptr;
int query_messages() { return w_ptr - r_ptr; }
// This function reads one mixed value from the fifo.
// If no values are available it blocks until a write has been done.
mixed read() {
mixed tmp;
object key=lock::lock();
while(!query_messages()) r_cond::wait(key);
tmp=buffer[r_ptr % sizeof(buffer)];
w_cond::signal();
return tmp;
}
// This function pushes one mixed value on the fifo.
// If the fifo is full it blocks until a value has been read.
void write(mixed v) {
object key=lock::lock();
while(query_messages() == sizeof(buffer)) w_cond::wait(key);
buffer[w_ptr % sizeof(buffer)]=v;
r_cond::signal();
}
R : An example for converting a number to english *LOOP T :ENTER A NUMBER, OR ZERO TO QUIT. C :$NUM= A :#Z E(Z=0) : U :*WRITNUM T :$NUM : J :*LOOP *WRITNUM U(Z<10) :*UNITS E(Z<10) : J(Z>999):*THOU J(Z>99) :*HUND J(Z>19) :*TWENTY C(Z=10) :$NUM=$NUM TEN C(Z=11) :$NUM=$NUM ELEVEN C(Z=12) :$NUM=$NUM TWELVE C(Z=13) :$NUM=$NUM THIRTEEN C(Z=14) :$NUM=$NUM FOURTEEN C(Z=15) :$NUM=$NUM FIFTEEN C(Z=16) :$NUM=$NUM SIXTEEN C(Z=17) :$NUM=$NUM SEVENTEEN C(Z=18) :$NUM=$NUM EIGHTEEN C(Z=19) :$NUM=$NUM NINETEEN E: *UNITS C(Z=1) :$NUM=$NUM ONE C(Z=2) :$NUM=$NUM TWO C(Z=3) :$NUM=$NUM THREE C(Z=4) :$NUM=$NUM FOUR C(Z=5) :$NUM=$NUM FIVE C(Z=6) :$NUM=$NUM SIX C(Z=7) :$NUM=$NUM SEVEN C(Z=8) :$NUM=$NUM EIGHT C(Z=9) :$NUM=$NUM NINE E: *TWENTY C:Y=Z%10 C:Z=Z-Y C(Z=20) :$NUM=$NUM TWENTY C(Z=30) :$NUM=$NUM THIRTY C(Z=40) :$NUM=$NUM FORTY C(Z=50) :$NUM=$NUM FIFTY C(Z=60) :$NUM=$NUM SIXTY C(Z=70) :$NUM=$NUM SEVENTY C(Z=80) :$NUM=$NUM EIGHTY C(Z=90) :$NUM=$NUM NINETY C:Z=Y E(Z=0) : J:*WRITNUM *HUND C :Y=Z%100 C :Z=(Z-Y)/100 U :*UNITS C :$NUM=$NUM HUNDRED C :Z=Y E(Z=0) : J :*WRITNUM *THOU C :X=Z%1000 C :Z=(Z-X)/1000 U :*WRITNUM C :$NUM=$NUM THOUSAND C :Z=X E(Z=0) : J :*HUND
FINDSTRINGS: PROCEDURE OPTIONS(MAIN)
/* READ A STRING, THEN PRINT EVERY */
/* SUBSEQUENT LINE WITH A MATCH */
DECLARE PAT VARYING CHARACTER(100),
LINEBUF VARYING CHARACTER(100),
(LINENO, NDFILE, IX) FIXED BINARY;
NDFILE = 0; ON ENDFILE(SYSIN) NDFILE=1;
GET EDIT(PAT) (A);
LINENO = 1;
DO WHILE (NDFILE=0);
GET EDIT(LINEBUF) (A);
IF LENGTH(LINEBUF) > 0 THEN DO;
IX = INDEX(LINEBUF, PAT);
IF IX > 0 THEN DO;
PUT SKIP EDIT (LINENO,LINEBUF)(F(2),A)
END;
END;
LINENO = LINENO 1;
END;
END FINDSTRINGS;
%!PS-Adobe-2.0
% Draw a string at an angle at a point
/printat { % str x y angle => -
gsave
4 1 roll translate
exch rotate 0 0 moveto show
grestore
} def
% find the center of the page
/pagecenter { % - => cx cy
clippath pathbbox 4 1 roll exch sub 2. div
3 1 roll sub 2. div
} def
% set up font and constants
/Times-Bold findfont 36 scalefont setfont
pagecenter /cy exch def /cx exch def
/steps 9 def
/basegray 0.75 def
/incrgray basegray steps div def
/baseangle 360 steps div def
/incrangle 360 steps div def
% draw a string as a rosette
steps {
basegray setgray
(PostScript) cx cy baseangle printat
/basegray basegray incrgray sub def
/baseangle baseangle incrangle add def
} repeat
% done with this page
showpage
% Quicksort in Prolog, by Keesey adapted from Bratko
gtq(X,Y) :- X @> Y.
quicksort( [],[] ).
quicksort( [X | Tail], Sorted) :-
split( X, Tail, Small, Big),
quicksort( Small, SortedSmall),
quicksort( Big, SortedBig),
conc( SortedSmall, [X | SortedBig], Sorted).
split( _, [], [], []).
split( X,[Y | Tail], [Y | Small], Big) :-
gtq( X, Y),!,
split( X, Tail, Small, Big).
split( X, [Y | Tail], Small, [Y | Big] ) :-
split( X, Tail, Small, Big).
conc([],L,L).
conc( [X | L1], L2, [X | L3]) :-
conc( L1, L2, L3).
# standard binary search tree from # a tree data structure package by Dan Stubbs # class binary_tree: def __init__ (self): self.tree = None def insert (self, key): if self.tree: self._insert (self.tree, key) else: self.tree = node(key) def _insert (self, tree, key): if key < tree.key: if tree.left: self._insert (tree.left, key) else: tree.left = node(key) else: if tree.right: self._insert (tree.right, key) else: tree.right = node(key)
'* Locates Find$ in sorted array Array$ () and returns element number or -1 *
'* by Matt Usner.
FUNCTION BinarySearch% (Array$(), Find$)
BinarySearch% = -1 ' no matching element yet
Min = LBOUND(Array$) ' start at first element
Max = UBOUND(Array$) ' consider through last
DO
Try = (Max + Min) \ 2 ' start testing in middle
IF Array$(Try) = Find$ THEN
BinarySearch% = Try ' return matching element
EXIT DO
END IF
IF Array$(Try) > Find$ THEN ' too high, cut in half
Max = Try - 1
ELSE
Min = Try + 1 ' too low, cut other way
END IF
LOOP WHILE Max >= Min
END FUNCTION
// code for items.qc to make a backpack
// bob in the water, by NiKoDeMoS, 1997.
void() Backpackfloat = {
local float pc;
pc = pointcontents(self.origin);
if (pc == CONTENTWATER)
self.velocity_z = (cvar("sv_gravity") + 100) * 0.1;
self.nextthink = time + 0.1;
};
REBOL [
Title: "99 Bottles of Beer on the Wall in REBOL"
Author: Neal Ziring
Email: ziring@home.com
Date: 17-Oct-1998
File: %99beer.r
Version: #REBOL-1-0-1
Purpose: "Print the famous iterative beer song"
Comment: {
This is an example of a program in REBOL that
prints the famous 99 bottles of beer on the
wall song. For more information on REBOL
go to the web site www.rebol.com.
This program is deliberately over-complicated
to hot-dog some fancy features of REBOL.
}
]
song: [
Verse [ [if num > 0 [num] else ["No more"] ] " "
[if num == 1 ["bottle"] else ["bottles"] ]
" of beer on the wall,"
1
[if num > 0 [num] else ["No more"] ] " "
[if num == 1 ["bottle"] else ["bottles"] ]
" of beer!"
1
"Take one down, pass it around!"
1
[if num - 1 > 0 [num - 1] else ["No more"] ] " "
[if num - 1 == 1 ["bottle"] else ["bottles"] ]
" of beer on the wall."
2
]
Finale [ "Time to buy more beer!" 1 ]
]
processItem: func [item num] [
if integer? item [loop item [prin newline] ]
if string? item [prin item]
if block? item [ftmp: func [num] item prin ftmp num ]
exit
]
dosong: func [start] [
bottlesleft: start
until [
foreach item song/Verse [processItem item bottlesleft]
bottlesleft: bottlesleft - 1
(bottlesleft == 0)
]
foreach item song/Finale [processItem item 0]
return none
]
dosong 99
PROCEDURE EUCLID(A,B,X);
BEGIN
SCALAR R,Q,AA,BB,SA,SB,SR,D;
CLEAR FIRST,SECOND;
AA := A; BB := B;
SA := FIRST; SB := SECOND;
WHILE (R := POLYREM(AA,BB,X)) NEQ 0 DO
<<ON GCD;
Q := (AA - R) / BB;
OFF GCD;
SR := SA - Q * SB;
D := DEN Q;
SA := SB * D; SB := SR * D;
AA := BB * D; BB := R * D>>;
RETURN SB
END;
/* Subroutine example from Ian Collier's tutorial, */
/* stand-in until I get a more extensive example. */
/* Calculate factorial x, that is, 1*2*3* ... *x */
parse pull x .
say x"!="factorial(x)
exit
factorial: /* calculate the factorial of the argument */
procedure
parse arg p
if p<3 then return p
else return factorial(p-1) * p
* A simple RPG subprocedure to determine
* an amount to pay a worker. From IBM
* book SC09-2074-01 "RPG/400 Programmer's Guide"
P CalcPay B
D CalcPay PI 8P 2
D Rate 5P 2 VALUE
D Hours 10U 0 VALUE
D Bonus 5P 2 VALUE
D Overtime S 5P 2 INZ(0)
* Determine any overtime hours to be paid.
C IF Hours > 40
C EVAL Overtime = (Hours - 40) * Rate * 1.5
C EVAL Hours = 40
C ENDIF
* Calculate the total pay and return it to the caller
C RETURN Rate * Hours Bonus Overtime
P CalcPay E
# sieve of Eratosthenes
max = Integer(ARGV.shift || 100)
sieve = []
for i in 2 .. max
sieve[i] = i
end
for i in 2 .. Math.sqrt(max)
next unless sieve[i]
(i*i).step(max, i) do |j|
sieve[j] = nil
end
end
puts sieve.compact.join ", "
# Some S code to plot concentric convex hulls
# around some data, from the documentation for
# the chull function.
drawhull <- function(xvec, yvec, ltype)
{
polygon(xvec, yvec, density=0, lty=ltype)
}
p <- chull(corn.rain, corn.yield, peel=T)
which <- rep(seq(p$count), p$count)
s <- split(p$hull, which)
plot(corn.rain, corn.yield, pch="X")
for(i in seq(s)) {
j <- s[[i]]
if (length(j) > 2)
drawhull(corn.rain[j], corn.yield[j], i)
}
-- Still working on a good code example here...
-- A simple class from the Sather Essential manual
class POINT is
attr x,y:INT;
create(x,y:INT):POINT is
res:POINT := new; res.x := x; res.y := y; return res;
end;
add(xval,yval:INT):POINT is
xsum:INT := x xval;
ysum:INT := y yval;
res:POINT := #POINT(xsum, ysum);
return res;
end;
offset_by(val:INT):POINT is
return add(val,val);
end;
end;
;;; takes two sorted lists merges them
(define (merge! a b less?)
(define (loop r a b)
(if (less? (car b) (car a))
(begin
(set-cdr! r b)
(if (null? (cdr b))
(set-cdr! b a)
(loop b a (cdr b)) ))
;; (car a) <= (car b)
(begin
(set-cdr! r a)
(if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) b)) )) )
(cond
((null? a) b)
((null? b) a)
((less? (car b) (car a))
(if (null? (cdr b))
(set-cdr! b a)
(loop b a (cdr b)))
b)
(else ; (car a) <= (car b)
(if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) b))
a)))
$ A SETL program to do the sieve of
$ Erastothenes (probably badly, but its my first
$ SETL program)
program sieve;
read(mx);
primes := {};
(for x in [3..mx] | odd x)
primes with:= x;
end;
(for x in [3..ceil(mx / 2)] | odd x)
primes := sieve1(x, primes);
end;
print(primes);
proc sieve1(rd n, rd pset);
(for x in pset | n < x and x mod n = 0)
pset less:= x;
end;
return pset;
end proc sieve1;
end program sieve;
#!/bin/sh
# Simple shell script to count files of size
# greater than 1k
if [ -z "$1" ]
then
pat="*"
else
pat="$1"
fi
cnt=0
for fname in $pat
do
if [ -r $fname -a ! -d $fname ]
then
size=`cat $fname | wc -c`
if [ $size -gt 1024 ]
then
echo $fname ' ' $size
cnt=`expr $cnt 1`
fi
fi
done
echo "${pat}: Files bigger than 1K: $cnt"
exit
Preamble
'' A simple telephone system model - CACI Products Company
'' files: TELPHN1.SRC
Normally mode is integer
Processes include
GENERATOR
Every INCOMING.CALL has
a CALL.ID
Define NUMBER.BUSY and
LOST.CALLS
as integer variables
End ''Preamble
Main
Activate a GENERATOR now
Start simulation
Print 1 line with LOST.CALLS thus
15 phone calls were made and ** were lost due to busy lines
End ''Main
Process GENERATOR
For I = 1 to 15 do
Activate a INCOMING.CALL now
Let CALL.ID(INCOMING.CALL) = I
Wait uniform.f (2.0, 6.0, 1) minutes
Loop
End ''GENERATOR
Process INCOMING.CALL
If NUMBER.BUSY < 2
Add 1 to NUMBER.BUSY
Wait uniform.f(6.0, 10.0, 2) minutes
Subtract 1 from NUMBER.BUSY
Else
Add 1 to LOST.CALLS
Endif
End ''INCOMING.CALL
Class Line(a,b,c); real a,b,c;
begin
boolean procedure parallelto(l); ref(Line) l;
if l =/= none then
parallelto := abs(a*l.b - b* l.a) < 0.00001;
ref(Point) procedure meets(l); ref(Line) l;
begin real t;
if l =/= none and ~parallelto(l) then
begin
t := 1/(l.a * b - l.b * a);
*** complicated expressions omitted below ***
meets :- new Point(..., ...);
end;
end; ***meets***
real d;
d := sqrt(a**2 b**2);
if d = 0.0 then error else
begin
d := 1/d;
a := a * d; b := b * d; c := c * d;
end;
end *** Line***
// an example from the Sina/st 3.1 distribution
main
comment '
Bring a salute to our globe';
temps
hello: HelloWorld;
begin
hello.show
end // main
#Category 'Sina-Hello world';
class HelloWorld interface
methods
show returns nil;
inputfilters
disp: Dispatch = {inner.*};
end; // interface HelloWorld
class HelloWorld implementation
methods
show
begin
self.printLine('Hello, world!');
return
end; // show
end; // implementation HelloWorld
% A simple example of using SISAL arrays,
% adapted from various sample exercises in the
% SISAL tutorial by John Feo.
define main
type Matrix = array [ array [ real ] ]
% generate a square matrix where element [n,m]
% is set to n m
function gensquare(siz : integer
returns Matrix )
for i in 1,siz cross j in 1,siz
returns array of real(i) real(j)
end for
end function
% perform one step of a relaxation, average each
% element with its eight nearest neighbors
function relax ( a : Matrix returns Matrix )
for row in a at i cross elt in row at j
avg := (elt a[i, j-1] a[i, j 1]
a[i 1, j-1] a[i 1, j] a[i 1, j 1]
a[i-1, j-1] a[i-1, j] a[i-1, j 1]) / 9.0
returns array of avg
end for
end function
% test the generator and relax function
function main(returns Matrix)
let a1 := gensquare(5) in a1
end let
end function
GEN, PEGDEN, SERIAL WORK AREAS QUEUE MODEL, 7/14/77, 1;
LIMITS,2,1,50;
NETWORK;
CREATE, EXPON(.4), , 1;
QUEUE(1), 0, 4, BALK(SUB);
ACT/1,EXPON(0.25);
QUEUE(2), 0, 2, BLOCK;
ACT/2,EXPON(0.50);
COLCT, INT(1), TIME IN SYSTEM, 20/0/.25
TERM;
SUB COLCT,BET,TIME BETWEEN BALKS;
TERM;
INIT,0,300;
FIN;
' Smalltalk class to constraint a 2D point to a fixed grid
' (from Horan & Hopkins, Smalltalk: An Introduction...)
Point subclass: #GriddedPoint
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Exercise11.5'!
!GriddedPoint methodsFor: 'accessing'!
x: xInteger
"Set the x coordinate gridded to 10 (using rounding, alternatively I could
use truncating)."
super x: (xInteger roundTo: 10)!
y: yInteger
"Set the y coordinate gridded to 10 (using rounding, alternatively I could
use truncating)."
super y: (yInteger roundTo: 10)! !
!GriddedPoint methodsFor: 'private'!
setX: xPoint setY: yPoint
"Initialize the instance variables rounding to 10."
super setX: (xPoint roundTo: 10) setY: (yPoint roundTo: 10)! !
* Find biggest words and numbers in a test string
* (from Griswold,Poage,& Polonsky, 1971)
BIGP = (*P $ TRY *GT(SIZE(TRY,SIZE(BIG))) $ BIG FAIL
STR = 'IN 1964 NFL ATTENDANCE JUMPED TO 4,807884; '
'AN INCREASE OF 401,810.'
P = SPAN('0123456789,')
BIG =
STR BIGP
OUTPUT = 'LONGEST NUMBER IS ' BIG
P = SPAN('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
BIG =
STR BIGP
OUTPUT = 'LONGEST WORD IS ' BIG
END
# Small Tcl sorting program, after Welch, 1997.
proc NameCompare {a, b} {
set $asurname = [lindex $a end]
set $bsurname = [lindex $b end]
set ret [string compare $asurname $bsurname]
if { $ret == 0 } {
$ret = [string compare $a $b]
}
return $ret
}
set namelist {}
set line {}
while { [gets stdin line] != 0 } {
lappend namelist $line
}
set namelist [lsort -command NameCompare $namelist]
set lineno 1
foreach line $namelist {
puts stdout "$lineno $line"
set lineno [expr $lineno 1]
}
! DISPLAY CURRENT LINE'S ASCII CODES, 20 PER DISPLAY-LINE.! ! D F KOENIG, 1989-11-24. ! @^U.L[^[^A Line length = ^A^[ MN0U.0^[QN<Q.0A:=^[^A ^A^[((%.0/10)*10)-Q.0"E^[((Q.0/20)*20)-Q.0"E^[^A ^A^[ ^[|^[^A ^A^[ ^['^['^[>^[^A ^A^[[
code Segment; \ define code Segment.
Org 0100h; \ all .COM programs start at 0100h.
data Segment; \ define data Segment.
' First2 ='1', =13, =10, \ Initial 2 primes message text...
='2', =13, =10, =24h; \ followed by a $ for DOS.
' Primes =" primes.", \ declare message text...
crlf =13, =10, =24h; \ followed by CR, LF and $ for DOS.
EOP Label Byte; \ define End Of Program.
data EndS; \ close data segment, goes after code.
\
\ Computes and displays all of the primes between 0 and 65536 using the
\ Eratosthenes' Sieve method. Note that the first 2 primes (1 and 2)
\ are handled as a special case.
\
\
dx = O(First2); ah = 9; !21h; \* print first 2 primes using DOS.
sp = O(EOP 512); \ set up 256 word stack at end of prog.
bx = sp 15 > 4; \ bx = number of paragraphs we use.
es = ds = ax = cs bx; \ setup ds,es to free space past stack.
cx = 32768; ax = (-1); &di; \ cx = number, ax = value, di = offset.
; <> ** =; \ auto-inc, clear full 64K flags array.
bx = 2; &si; &ch; \ count = 2 (for 1 & 2), i = 0, ch = 0.
{ \ do...
cl = [si]; ?<> \ if flags[i] is non-zero...
{ \ then...
dx = si si 3; <<1; \ prime = i * 2 3, break if done...
ax = dx; =.PrintNum; \* print prime using PrintNum.
ax = H(14) L(13); !10h; \* print CR using BIOS.
ax = H(14) L(10); !10h; \* print LF using BIOS.
di = si dx; >> \ k = i prime, if & while k << limit,
{ [di] = ch; di dx; }>>; \ do flags[k] = 0, k = k prime.
bx ; \ count = count 1;
}; \ endif flags[i] is non-zero.
si ; \ i = i 1.
}.; \ loop forever-- break gets us out.
es = ds = ax = cs; \ restore ds and es.
ax = bx; =.PrintNum; \ print ax in decimal to screen.
dx = O(Primes); ah = 9; !21h; \ print " primes." using DOS.
!20h; \ return to DOS.
% Code to test whether a given year is
% a leap-year. From
% S. Bechtolsheim's "TeX in Practice" volume 3.
\InputD{imodn.tip}
\newif\if@LeapYear
\def\LeapYearConditional #1{%
TT\fi
{%
\count0 = #1\relax
\IModN{\count0}{4}{\count1}%
\ifnum\count1 = 0
\global\@LeapYeartrue
\IModN{\count0}{100}{\count2}%
\IModN{\count0}{400}{\count3}%
\ifnum\count2 = 0
\global\@LeapYearfalse
\fi
\ifnum\count3 = 0
\global\@LeapYeartrue
\fi
\else
\global\@LeapYearfalse
\fi
}%
\if@LeapYear
}
% Roll a die until you get 6. (This is a comment)
var die : int
loop
randint (die, 1, 6)
exit when die = 6
put "This roll is ", die
end loop
put "Stopping with roll of 6"
** An example numerical integration program
** from the UFO1.0 Tutorial by J. Sargeant.
polyf (x : Float) : Float is
2*x*x + 6*x + 1
trap(f: Float -> Float; a,b,approx : Float; n : Int) : Float is
{
h = (b - a) / n;
return approx/2 + h*
initially s = 0.0;
for i in [1 to n step 2] do
x = a + i * h ;
new s = s + f(x) ;
return s
od
}
integrate(f : Float -> Float; a, b: Float) : Float is
initially done = false;
n = 1 ;
integral = (f(a) + f(b)) * (b - a) / 2;
while not done do
next_integral = trap(f, a, b, integral, 2 * n) ;
new n = 2 * n ;
new done = abs(next_integral - integral) < 1.0e-4
new integral = next_integral
return next_integral
od
main : String is
"Integral is " ++ print(integrate(Float|polyf, 1.0, 6.0) ++ "\n"
An example of using VBScript to check form data.
Function isSSN(ssns)
isSSN = False
If (len(ssns) = 9 or len(ssns) = 11) Then
isSSN = True
End If
End Function
Sub submit_OnClick
dim namestr, ssnstr, psw, req
set form = document.form1
namestr = Trim(form.NameStrField.Value)
ssnstr = Trim(form.SSNStrField.Value)
If (len(namestr) = 0) Then
msgbox "Name is empty, please type in your name"
Exit Sub
ElseIf (not isSSN(ssnstr)) Then
msgbox "SSN field is not the right length, please fix it"
Exit Sub
Else
psw = InputBox("Enter your password:","Form Password","")
End If
req = "http://test.org/cgi/start.cgi?ssn=" &
ssnstr & "&passwd=" psw
loc.href = req
End Sub
-- Behavioral model of a D flip-flop, from
-- the US Army FCIM VHDL Tutorial.
USE WORK.std_logic_1164.ALL
ENTITY mydff IS
GENERIC(q_out, qb_out :time);
PORT(preset, clear, din, clock: :IN std_logic;
q, qb : :OUT std_logic);
END mydff
ARCHITECTURE behavioral OF mydff IS
BEGIN
mydff_proc : PROCESS(preset, clear, clock)
VARIABLE int_q :std_logic;
BEGIN
IF preset = '0' AND clear = '0' THEN
IF(clock'EVENT) AND (clock = '1') THEN
int_q := din;
END IF;
ELSEIF preset = '1' AND clear ='0' THEN
int_q := '1';
ELSEIF clear = '1' AND preset = '0' THEN
int_q := '0';
ELSE
int_q := 'X';
ENDIF;
q <= int_q AFTER q_out;
int_q := NOT(int_q);
qb <= int_q AFTER qb_out;
END PROCESS mydff_proc;
END behavioral;
' Simple program to compute factorials
' (placeholder until I write a better example)
Function factorial(n as Long)
If (n <= 0) Then
factorial = 1
Else
factorial = n * factorial(n - 1)
End If
End Function
Dim fx(12) as Long
For i = 1 to 12
fx(i) = factorial(i)
Next
func cmplxplot(z, u)
/* DOCUMENT cmplxplot, z, u
* plots a scalar complex function of a complex variable. */
{
resx=100; resy=100;
s=[[sqrt(2./3.),0,1/sqrt(3)],[-1/sqrt(2*3.0),1/sqrt(2.),1/sqrt(3)],
[-1/sqrt(2*3.0),-1/sqrt(2.),1/sqrt(3)]];
phi=span(-pi,pi,256);
vec=array(double,3,256);
vec(1,)=cos(phi); vec(2,)=sin(phi); vec(3,)=1/sqrt(2)(-);
f=s(+,)*vec(+,);
palette,bytscl(f(2,),top=255),bytscl(f(1,),top=255),bytscl(f(3,),top=255);
xmin=min(u.re); xmax=max(u.re);
ymin=min(u.im); ymax=max(u.im);
zi=array(complex,resx,resy);
zi.re=interp2(span(ymin,ymax,resy)(-:1:resx,),span(xmin,xmax,resx)(,-:1:resy),
z.re,u.im,u.re);
zi.im=interp2(span(ymin,ymax,resy)(-:1:resx,),span(xmin,xmax,resx)(,-:1:resy),
z.im,u.im,u.re);
// Caution: on some platforms atan(0,0) crashes !
arr=bytscl(atan(zi.im,zi.re+1e-200),cmin=-pi,cmax=pi);
pli,arr, xmin,ymin,xmax,ymax;
plc,abs(z),u.im,u.re,marks=0;
}
One of the most novel aspects of ZPL is its facility for defining regions of arrays for parallel operations, and directions of array offsets. Associated with this facility are some array structuring features including wrapping, reflecting, and flooding of array dimensions.
program jacobi;
config var n : integer = 5; -- Declarations
delta : float = 0.0001;
region R = [1..n, 1..n];
direction north = [-1, 0]; south = [ 1, 0];
east = [ 0, 1]; west = [ 0,-1];
procedure jacobi(); -- Entry point
var A, Temp : [R] float;
err : float;
begin
[R] A := 0.0; -- Initialization
[north of R] A := 0.0;
[east of R] A := 0.0;
[west of R] A := 0.0;
[south of R] A := 1.0;
[R] repeat -- Main body
Temp := (A@north+A@east+A@west+A@south) / 4.0;
err := max<< abs(A-Temp);
A := Temp;
until err < delta;
[R] writeln(A); -- Output result
end;
Information about the dictionary:
Here are some other sites that have surveys or dictionaries of programming languages.
NCSA Computing Languages List
Tunes Review of Programming Languages
More Programming Language Resource Links..
WWW Virtual Library: Computing, Programming Languages
Descriptions in this dictionary are ©1997-99 Neal Ziring. Some examples copyright of their respective authors. Some technologies and languages are trademarked. Permission to copy descriptions is granted as long as authorship credit is preserved.
Comments on this dictionary, corrections and suggestions, are all welcome. Please use email, the address is ziring@home.com
[Ziring MicroWeb Home] [Dictionary Start] [Sign Guestbook]
Dictionary and script maintained by Neal Ziring, last major modifications 3/18/98. Most recent additions to dictionary and master list, 1/00.