BYTE Listings Jul Sep 1987

Byte

This book was produced in EPUB format by the Internet Archive.

The book pages were scanned and converted to EPUB format automatically. This process relies on optical character recognition, and is somewhat susceptible to errors. The book may not offer the correct reading sequence, and there may be weird characters, non-words, and incorrect guesses at structure. Some page numbers and headers or footers may remain from the scanned page. The process which identifies images might have found stray marks on the page which are not actually images from the book. The hidden page numbering which may be available to your ereader corresponds to the numbered pages in the print edition, but is not an exact match; page numbers will increment at the same rate as the corresponding print edition, but we may have started numbering before the print book's visible page numbers. The Internet Archive is working to improve the scanning process and resulting books, but in the meantime, we hope that this book will be useful to you.

The Internet Archive was founded in 1996 to build an Internet library and to promote universal access to all knowledge. The Archive's purposes include offering permanent access for researchers, historians, scholars, people with disabilities, and the general public to historical collections that exist in digital format. The Internet Archive includes texts, audio, moving images, and software as well as archived web pages, and provides specialized services for information access for the blind and other persons with disabilities.

Created with abbyy2epub (v.1.7.2)

Six great reasons to join EIX today

• Over 140 microcomputer-related conferences:

loin only those subjects that interest you and change selections at any time. Tcike part when it's convenient for you. Share information, opinions and ideas in focused discussions with other BIX users who share your interests. Easy commands and conference digests help you quickly locate important information.

• Monthly conference specials:

BIX specials connect you with invited experts in leading-edge topics—CD-ROM. MIDI. OS-9 and more. They're all part of your BIX membership.

• Microbytes daily:

Get up-to-the-minute industry news and new product information by joining Microbytes Daily and What's New Hardware and Software.

• Public domain software:

Yours for the downloading, including programs from BYTE articles and a growing library of PD listings.

• Electronic mail:

Exchange private messages with BYTE editors and authors and other BIX users.

BIX User's Manual and Subscriber Agreement as Soon as We've Processed Your Registration. JOIN THE EXCITING WORLD OF BIX TODAY!

• Vendor support:

A growing number of microcomputer manufacturers use BIX to answer your questions about their products and how to use them for peak performance.

What BIX Costs. .How You Pay

JOIN BIX RIGHT NOW:

Set your computer's telecommunications program for full duplex. 8-bit characters, even parity. 1 stop bit OR 7-bit characters, even parity. 1 stop using 300 or 1200 baud.

Call your local Tymnet number and respond as follows:

ONE-TIME REGISTRATION FEE S25

Hourly

Charges:

(Your Time of Access)

Off-Peak

6PM-7AM

Weekdays Plus Weekends & Holidays

Peak

7AM-6PM

Weekdays

Tymnet Prompt

Garble or "terminal identifier”

login:

password:

mhis login:

BIX Logo—Name:

You Enter

a

byteneti <CR> mgh <CR> bix <CR> new <CR>

BIX $9 $12

Tymnet* $2 $6

TOTAL SI I/hr. $I8/hr.**

■ Continental U S. BIX is accessible via Tymnet from throughout the US. at charges much less than regular long distance. Call the BIX helpline number listed below for the Tymnet number near you or Tymnet at 1-800-336-0149 ' * User is billed for time on system lie.. VS Hr. Off-Peak wTTymnet - S5.50 charge .I

BIX and Tymnet charges billed by Visa or Mastercard only.

BIX Helpline

(8:30 AM-11:30 PM Eastern Weekdays)

U.S. (except NH)-l-800-227-BYTE Elsewhere (603) 924-7681

After you register on-line, you're immediately taken to the BIX learn conference and can start using the system right away.

Foreign access:

To access BIX from foreign countries, you must have an account with your local Postal Telephone & Telegraph (PTT) company. From your PTT enter 310600157878. Then enter bix <CR> and new <CR> at the prompts. Call or write us for PTT contact information.

EIX

One Phoenix Mill Lane Peterborough, NH 03458 (603) 924-9281

TABLE OF CONTENTS

July.5

August.37

September.89

WELCOME TO BYTE’S QUARTERLY LISTINGS SUPPLEMENT

The BYTE Listings Supplement is produced quarterly as a means of providing interested readers with a printed, source code version of those programs referenced in BYTE articles.

It provides a far more extensive look into the techniques of coding and the potentialities of microcomputers than we have space for in each month’s BYTE.

Programs contained in this Supplement are referenced by the month the article appeared, the page on which their supporting article begins, and the name of the author who wrote the article.

For those who prefer programs already in electronic format, we have a companion service called Listings on Disk. If you have a modem, listings may be downloaded from the BYTEnet bulletin board and, if you are a member of BIX, the “Listings” area also contains programs referenced in BYTE.

If you live outside of the U.S., we’ve included the names, addresses and telephone numbers of bulletin boards that get program code from us. You’ll find the directory just inside the back cover of this Supplement.

The bulletin boards are updated monthly. Several countries have enough boards that the telephone charges for most callers should be the minimum possible.

Copyright © 1987 by McGraw-Hill Inc. All rights reserved.

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 1

EXECUTIVE EDITOR, BYTE EXECUTIVE EDITOR, BIX

Frederic S. Langa George Bond

ASSISTANT MANAGING EDITOR

Glenn Hartwig

CONSULTING EDITORS Steve Ciarcia Jerry Pournelle Ezra Shapiro

SENIOR TECHNICAL EDITORS

Cathryn Baskin, Reviews G. Michael Vose, Themes Gregg Williams, Features

TECHNICAL EDITORS Dennis Allen Curtis Franklin Jr.

Richard Grehan Ken Sheldon George A. Stewart Jane Morrill Tazelaar Tom Thompson Charles D. Weston Eva White Stanley Wszola

ASSOCIATE TECHNICAL EDITORS Martha Hicks

COPY EDITORS

Lauren Stickler, Copy Administrator

Judy Connors-Tenney

Jeff Edmonds

Nancy Hayes

Cathy Kingery

Margaret A. Richard

Warren Williamson

ASSISTANTS

Peggy Dunham. Office Manager L Ryan McCombs Juno N Sheldon

NEWS AND TECHNOLOGY

Gene Smarte, Bureau Chief. Costa Mesa Jonathan Erickson, Senior Technical Editor, San Francisco

Rich Malloy, Senior Technical Editor. New York Nicholas Baran, Associate Technical Editor, San Francisco

ASSOCIATE NEWS EDITORS

Dennis Barker, Microbytes

Anne Fischer Lent, What’s New

Stan Miastkowski, What’s New, Best of BIX

CONTRIBUTING EDITORS

Jonathan Amsterdam, programming projects Mark Dahmke, video, operating systems Mark Haas, at large

Rik Jadrnicek, CAD. graphics, spreadsheets Robert T. Kurosaka, mathematical recreations Alastair J.W. Mayer, software Alan R. Miller, languages and engineering Dick Pountain, U.K.

Roger Powell, computers and music Phillip Robinson, semiconductors Jon Shiell, high performance systems

ART

Nancy Rice, Art Director

Joseph A. Gallagher, Assistant Art Director

Jan Muller, Art Assistant

Alan Easton, Drafting

PRODUCTION

David R. Anderson, Production Director Denise Chartrand Michael J. Lonsky Virginia Reardon

TYPOGRAPHY

Shorry McCarthy, Chief Typographer Sollnda Chlquoino Donna Swoonoy

SENIOR EDITOR David Betz

ASSOCIATE EDITORS

Tony Lockwood

Donna Osgood, San Francisco

MICROBYTES DAILY

Dennis Barker, Coordinator, Peterborough

Gene Smarte, Bureau Chief, Costa Mesa

Nicholas Baran, San Francisco

Rick Cook, Phoenix

Jonathan Erickson, San Francisco

Martha Hicks, Peterborough

Anne Fischer Lent, Peterborough

Larry Loeb, Wbllingford, CT

Rich Malloy, New York

Brock N. Meeks, La Mesa, CA

Jeff Merron, Peterborough

Stan Miastkowski, Peterborough

Lynne Nadeau, Peterborough

Wayne Rash, Washington. DC

GROUP MODERATORS

David Allen, Applications

Frank Boosman, Artificial Intelligence

Leroy Casterline, Other

Marc Greenfield, Programming Languages

Jim Howard, Graphics

Gary Kendall, Operating Systems

Steve Krenek, Computers

Brock N. Meeks, Telecommunications

Barry Nance, New Technology

Donald Osgood, Computers

Sue Rosenberg, Other

Jon Swanson, Chips

BUSINESS AND MARKETING

Doug Webster, Director (603-924-9027) Patricia Bausum, Secretary Denise A. Greene, Customer Service Brian Warnock, Customer Service Tammy Burgess, Customer Credit and Billing

TECHNOLOGY

Clayton Lisle, Director Business Systems Technology, MHIS Bill Garrison, Business Systems Analyst Jack Reilly, Business Systems Analyst

Officers of McGraw-Hill Information Systems Company: President: Richard B. Miller Executive Vice Presidents: Frederick P. Jannott, Construction Information Group; Rus sell C. White, Computers and Communications Information Group; J. Thomas Ryan. Marketing and International. Senior Vice Presidents: Francis A. Shinal, Controller; Robert C, Viol cue, Manufacturing and Technology. Senior Vice Presidents and Publishers: Laurence Altman, Electronics; Harry L. Brown. BYTE; David J. McGrath. Construction Publications. Group Vice President: Peter B. McCucn, Communications Information. Vice President: Fred O. Jensen. Planning and Development.

Officers of McGraw-Hill, Inc.: Harold W. McGraw, Jr.. Chairman; Joseph L. Dionne, President and Chief Executive Officer; Robert N. Landes. Executive Vice President and Secretary; Walter D. Serwatka. Executive Vice President and Chief Financial Officer; Shcl F. Ascn, Senior Vice President. Manufacturing; Robert J. Hahash, Senior Vice President, Finance and Manufacturing; Ralph R. Schulz, Senior Vice President. Editorial; George R. Elsinger, Vice President, Circulation; Ralph J. Webb, Vice President and Treasurer.

BYTE, , and The Small Systems Journal arc registered trademarks of McGraw-Hill Inc.

EDITORIAL AND BUSINESS OFFICE: One Phoenix Mill Lane, Peterborough. New Hampshire 03458, (603) 924-9281.

SB

West Coast Offices: 425 llatteiy St , San Francisco. CA ‘Mill, (415)954 9718; 3001 Red Mill Avc., Building II. Suite 222, Costa Mesa, CA 92626, (714) 557 6292. New York Editorial Office: 1221 AvtMIt <4 tin- AlMriCMi Now York. NY 10020,(212)512 H 7s

BY I F.net: (617) 861 9764 (set modem at 8 I N or 7-1 E; 300 or 1200 baud).

BY TE (ISSN 0360-5280) is published monthly with additional issues in June and October by McGraw Hill IiK' • Founder: James 11 McGraw < I KM) I94K). Executive, editorial, circulation. and advertising offices: One Phoenix Mill Lane, Peterborough, NH 03458. phone (603) 924 9281. Office hours: Monday through Thurs day 8:30 AM-4:30 PM, l-riday 8:30 AM I :00 PM. Eastern Time. Address subscriptions to BYTE. Subscrip lions, P.O. Box 590, Martinsville. NJ 08836. f\»stmastcr send address changes, USPS Form 3579, undclivcr able copies, and fulfillment questions to BYTE Subscriptions. P.O. Box 596. Martinsville. NJ 08836. Second class postage paid at Peterborough, NH 03458 and additional mulling offices, histage paid at Winnipeg. Manitoba Registration number 9321. Subscriptions arc $22 for one year, $40 for two years, and $58 for three years in the U.S. and its possessions. In Canada and Mexico. $25 fine one year, $45 for two years, $65 for three years. $69 for one year air delivery to Europe. 31,000 yen for one year air delivery to Japan. I5.MX) yen for one year surface delivery to Japan. $37 vui race delivery elsewhere. Air delivery to selected areas at additional rates upon request. Single copy price is $3.50 in the U S. and its possessions. $4 25 in Canada and Mexico. $4.50 in Europe, and $5 elsewhere. Foreign subscriptions and sales should be remitted inU.S. funds drawn on a U.S. hank. Please allow six tocight weeks lor delivery of first issue. Printed in the United Stales of America.

Address editorial correspondence to: Editor, BYTE, One Phoenix Mill lane. Peterborough, NH 03458. Unacceptable manuscripts will be returned if accompanied by sufficient (lostage. Not responsible for lost manuscripts or photos. Opinions expressed hy the authors arc not necessarily those of BYTE.

Copyright © 1987 hy McGraw-Hill Inc, All rights reserved. Trademark registered in the United States Patent and Trademark Office. Where necessary, permission is grunted by the copyright owner for libraries ami others registered with the Copyright Clearance Center (CCC) to photocopy any article herein for the flat fee of $1 50 per copy of the article or any part thereof. Correspondence and payment should he sent directly in the CCC. 29 Congress St.. Salem, MA 01970. Specify ISSN 0360 5280/83 $1.50 Copying done for other than personal or internal reference use without the permission of McGraw Hill Inc. is prohibited Requests lor s|kviuI pci mission or hulk orders should he addressed to the publisher. BYTE is uvwiluhlr m microfnrm Ironi University Microfilms International. .300 North Zecb Rd.. Dept PR. Ann Arbor, Ml 4KI06ur 18 Bedford Row, Dept PR, lamdon WC’IR 4EJ. England Subscription questions or problems should be mldrsscii to: BYTE Subsc riber Service. P.O Box 328. Hancock, NH 03449.

2 BYTE LISTINGS SUI’I’I .EM ENT • JULY SI P11 Mill K, IUK7

INDEX

July

BENCH ADA.5

DHRY C.13

FIB C.23

FILEIO C.26

FLOAT C.23

LISTING TXT.35

LISTING2 TXT.33

SAVAGE C.26

SIEVE C.24

SORT C.24

USORT PAS.31

WHET C.27

August

CHAOSBEN BAS.87

DONE C.84

DRAGON BAS.49

FIB C.84

FILEIO C.85

FLOAT C.83

HELP80 ARI.67

INDEX PAS.53

INTERFAC C.78

MEMORY ARI.76

MEMORY BAS.78

MON80 ARI.74

OPS8085 ARI.55

PARSE80 ARI.72

PREDS80 ARI.69

QAROHEAD CRV.39

QBRICK CRV.40

QBRKINT CRV.40

QCHRSTRE CRV.43

QDEKNGCH CRV.37

QDRAGON BAS.51

QDRGBDRY CRV.41

QDRGN CRV.44

QDRGNCRD CRV.43

QDRGNINT CRV.37

QGOSPER CRV.44

QHILBRT CRV.37

QLACE CRV.40

QMDLQUIN CRV.42

QMOORE CRV.42

QPENTGRE CRV.38

QRULES TXT.50

QSNOFLK CRV.38

QSRPNSK CRV.38

QSRPNSK2 CRV.42

SAVAGE C.82

SIEVE C.80

SORT C.81

START80 ARI.79

STARTUP C .76

SZPAK BNL.46

SZPAK LST.44

TOKENS80 ARI.77

September

ADD-PATT C.124

ALSPRO TST.89

ASYNCH C. 126

AWAIT C.126

BAM BAS.116

BAM PAS.99

BAM C. 132

CLEARBAM C.133

EXT H. 132

GET—MTX C.131

KAREX1 BAS.140

KAREX2 BAS.138

KAREX3 BAS.97

PAT 1.132

README BAM.125

SIEVE386 ASM.127

SIEVE86 ASM.134

SORT MOD. 124

SORT DEF.125

SORTELEM MOD.121

SORTELEM DEF.123

SORTTEST MOD.122

TURBFLOP PRO. 138

XFACE INC. 114

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 3

BENCH. ADA Contributed by Namir Clement Shammas.

Listings accompany the review of four Ada compilers: Alsys Ada, Artek Ada, AdaVantage, and JANUS Ada, "Ada Moves to Micros," July 1987, page 239.

Listing 1: Source code for Ada Sieve benchmark program.

with TEXT_IO; use TEXT.IO;

— package INTIO is new INTEGER__IO( INTEGER);

PROCEDURE MTSIE10 is

SIZE : constant INTEGER := 7000;

TYPE Flag_Array is array(0. .SIZE) of BOOLEAN;

PRIME, K, COUNT : INTEGER;

FLAGS : Flag_Array;

BEGIN

PUT_LINE(’'START TEN ITERATIONS”);

FOR ITER INI.. 10 LOOP COUNT := 0;

FORI IN 0.. SIZE LOOP FLAGS(I) := TRUE;

END LOOP;

FORI IN 0.. SIZE LOOP

IF FLAGS(I) THEN PRIME := I + 1 + 3;

K := I + PRIME;

WHILE K <= SIZE LOOP FLAGS(K) := FALSE;

K : = K + PRIME;

END LOOP;

COUNT : = COUNT + 1;

END IF;

END LOOP;

END LOOP;

PUT(INTEGER'IMAGE(COUNT));

PUT_LINE(" PRIMES");

END MTSIE10;

Listing 2: Source code for Ada integer Sort benchmark program.

with TEXT.IO; use TEXT.IO;

Procedure MTSort2 is

— Program will test the speed of sorting an integer array.

— The program will create an array sorted from smaller to larger

— integers, then sort them in the reverse order.

— The array is reverse-sorted ten times.

continued

BYTE LISTINGS SUPPLEMENT

JULY-SEPTEMBER. 1987 5

package INTIO is new INTEGER_IO( INTEGER);

SIZE : constant :* 1000;

TYPE NUMBERS is ARRAY(1. .SIZE) OF INTEGER;

InOrder, AscendingOrder : BOOLEAN;

Offset, Temporary : INTEGER;

Ch : CHARACTER;

A : NUMBERS;

PROCEDURE InitializeArray is

— Procedure to initialize array BEGIN

PUT_LINE("Initializing integer array");

FORI INI.. SIZE LOOP A(I) := I;

END LOOP;

END InitializeArray;

PROCEDURE ShellSort is

— Procedure to perform a Shell-Metzner sorting I : INTEGER;

PROCEDURESwapThem(I, J : in INTEGER) is

— Local procedure to swap elements A(I) and A(J)

BEGIN

InOrder := FALSE;

Temporary := A(I);

A(l) := A(J);

A(J) :* Temporary;

END SwapThem;

BEGIN

— Toggle "AscendingOrder" flag status Ascend ingOrder :* NOT AscendingOrder;

Offset := SIZE;

WHILE Of fset > 1 LOOP Offset :« Offset/2;

LOOP

InOrder := TRUE;

FOR J IN 1.. (SIZE - Offset) LOOP I : = J + Offset;

IF AscendingOrder

THEN IF A(I) < A(J) THEN SwapThem(I, J); END IF; ELSE IF A(I) > A(J) THEN SwapThem (I, J); END IF; END IF; — AscendingOrder END LOOP;

IF InOrder THEN EXIT; END IF;

END LOOP;

END LOOP;

END ShellSort;

PROCEDURE DisplayArray is

— Display array members BEGIN

FORI INI.. SIZE LOOP INTIO.PUT(A(I) ,3) ;

p UT (» »•);

END LOOP;

NEW_LINE;

END DisplayArray;

BEGIN — Main InitializeArray;

AscendingOrder :* TRUE;

PUT("Beginning to sort press <cr> "); GET(Ch); NEW.LINE; FOR Iter INI.. 10 LOOP PUT(".»);

ShellSort;

END LOOP;

PUT_LINE("Finished sorting!");

DisplayArray;

END MTSort2;

6 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

Listing 3: Source code for Ada basic Floating benchmark program.

WITH TEXT.IO; USE TEXT.IO;

PROCEDURE MTFLOAT is

PACKAGE ReallnOut is new FLOAT. 10(FLOAT);

USE ReallnOut;

NR : CONSTANT INTEGER := 5000;

A, B, C : FLOAT;

BEGIN

A :* 2.71828;

B := 3.1459;

C := 1.0;

FORI INI..NR LOOP C :» C * A;

C :»C*B;

C :=C/A;

C := C / B;

END LOOP;

PUT("D0NE");

NEW.LINE;

PUT("ERROR »");

PUT((C-1.0));

NEW.LINE;

END MTFLOAT;

Listing 4: Source code for Ada matrix-inversion Floating benchmark program.

with TEXT.IO; use TEXT.IO;

Procedure MTINVERT is

— Program to test speed of floating-point matrix inversion.

— The program will form a matrix with Is in every member,

— except the diagonals which will have values of 2.

package ReallnOut is new FLOAT. 10(FLOAT);

MAX : constant :* 20;

TYPE MATRIX is ARRAY (1..MAX, 1. .MAX) OF FLOAT;

J, K, L: INTEGER;

DET, PIVOT, TEMPO: FLOAT;

A: MATRIX;

Procedure Invert is

BEGIN

— Creating test matrix FOR J INI.. MAX LOOP

FORK INI.. MAX LOOP A(J, K) :■ 1.0;

END LOOP;

A(J, J) :■ 2.0;

END LOOP;

PUT_LINE("Startingmatrix invertion");

DET :» 1.0;

continued

BYTE LISTINGS SUPPLEMENT

JULY-SEPTEMBER. 1987 7

FOR J INI..MAX LOOP

PIVOT := A(J, J);

DET : = DET#PIVOT;

A(J, J) := 1.0;

FORK INI.. MAX LOOP

A(J, K) := A(J, K)/ PIVOT;

END LOOP;

FORK INI.. MAX LOOP

IF K/* J THEN

TEMPO : = A(K, J);

A(K, J) : = 0.0;

FOR L INI..MAX LOOP

A(K, L) := A(K, L) - A(J, L) # TEMPO;

END LOOP;

END IF;

END LOOP;

END LOOP;

END Invert;

BEGIN

NEWSLINE(2);

Invert;

PUT( "Determinant = ");

RealInOut.PUT(DET,14,10); NEW_LINE(2);

END MT INVERT;

Listing 5: Source code for Ada Math Functions benchmark program.

— use Janus/Ada libraries WITH TEXT_I0; WITH SMATHLIB;

USE TEXT_IO; USE SMATHLIB;

PROCEDURE MTMath is

— Program tests the speed of math function.

— Each function is timed separately.

— Functions are shown in the import list.

pi, angle, result, argument: FLOAT; dummy: CHARACTER;

BEGIN

PUT_LINE("START SQUARE ROOT TEST");

PUT( "PRESS <CR> TO START");

GET(dummy); New.Line;

FOR i ini.. 10 LOOP PUT("."); argument := 0.0;

WHILE argument <= 1000.0 LOOP result :» Sqrt(argument); argument := argument + 1.0;

END LOOP;

END LOOP;

New_Line; PUT("END OF SQUARE ROOT TEST"); Nev_Line;

8 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

PUT("START LOG TEST");

Nev_Line;

PUT("PRESS <CR> TO START");

GET(dummy); New_Line; /

FOR i ini.. 10 LOOP PUT("."); argument :* 0.1;

WHILE argument <= 1000.1 LOOP result : = Log(argument); argument : = argument + 1.0;

END LOOP;

END LOOP;

New.Line; PUT("END0F LOG TEST"); Nev_Line;

PUT("START EXPONENTIAL TEST");

New_Line;

PUT ("PRESS <CR> TO START");

GET (dummy); New_Line;

FOR i ini..10 LOOP PUT("."); argument := 0.1;

WHILE argument <=10.0 LOOP result := exp(argument); argument : = argument + 0.01;

END LOOP;

END LOOP;

New_Line; PUT( "END OF EXPONENTIAL TEST"); New_Line;

PUT( "START ARCTANGENT TEST");

New_Line;

PUT( "PRESS <CR> TO START");

GET (dummy); New_Line;

FOR i ini..10 LOOP PUT("."); argument :* 0.1;

WHILE argument <=10.0 LOOP angle := arctan(argument); argument : = argument + 0.01;

END LOOP;

END LOOP;

New.Line; PUT( "END OF ARCTANGENT TEST"); New_Line;

pi := 355.0/113.0;

PUT( "START SINE TEST");

New_Line;

PUT( "PRESS <CR> TO START");

GET (dummy); New_Line;

FOR i ini.. 10 LOOP PUT("."); angle :■ 0.0;

WHILE angle <= 2.0 * pi LOOP result :■ sin(angle); angle := angle + pi/360.0;

END LOOP;

END LOOP;

New_Line; PUT("END OF SINE TEST"); Nev_Line;

New_Line;

PUT("DONE"); New_Line; New.Line;

END MTMath;

Listing 6: Source code for Ada Recursion benchmark program.

with TEXT_I0; use TEXT_IO;

Procedure MTQSort la continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 9

— The test uses Quicksort to measure recursion speed.

— An ordered array is created by the program and is

— reverse-sorted. The process is performed "MAX I TER"

— number of times.

package Int_IO is new INTEGER_IO(INTEGER);

SIZE : constant := 1000;

MAXITER : constant :=10;

WantToListArray : constant BOOLEAN FALSE; — Flag used for debugging TYPE Numbers is ARRAY(1. .SIZE) OF INTEGER;

A : Numbers;

PROCEDURE InitializeArray is

— Procedure to initialize array

BEGIN

FORI ini.. SIZE LOOP A(I) := SIZE-1 + 1$

END LOOP;

NEW_LINE(3);

END InitializeArray;

PROCEDURE Quicksort is

— Procedure to perform a Quicksort

PROCEDURESort(Left, Right : INTEGER) is

i, J ; INTEGER;

Datal, Data2 : INTEGER;

BEGIN

i := Left; J Right;

Datal : = A( (Left + Right) / 2);

LOOP

WHILE A(i) < Datal LOOP i :* 1 + 1; END LOOP;

WHILE Datal < A(J) LOOP J :■ J -1; END LOOP;

IF i <= J THEN

Data2 :* A(i); A(i) := A(J); A(j) :=Data2; i ;• i + 1;

J := J -1;

END IF;

IFi> j THEN EXIT; END IF;

END LOOP;

IF Left < j THEN Sort(Left, j); END IF;

IF i < Right THEN Sort(i,Right); END IF;

END Sort;

BEGIN

Sort(l,SIZE);

END Quicksort;

PROCEDURE DisplayArray is

— Display array members BEGIN

FORI ini.. SIZE LOOP Int_I0.PUT(A(I),4);

PUT(" ");

END LOOP;

NEW_LINE;

END DisplayArray;

BEGIN — Main

FOR Iter in 1. .MAXITER LOOP InitializeArray;

PUT(".");

Quicksort;

END LOOP;

NEW.LINE;

PUT_LINE("Finished sorting!");

IF WantToListArray THEN DisplayArray; END IF;

END MTQSort;

10 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

Listing 7: Source code for Ada Dynamic Allocation benchmark program.

with TEXT_I0; use TEXT_I0;

PROCEDURE MTPtr is

— Program to measure the speed of:

— 1) Allocating dynamic binary-tree structure

— 2) Searching through the binary tree

SIZE : constant INTEGER := 1000;

MainLoopCount : constant INTEGER := 200;

TYPE Node;

TYPE Ptr is access Node;

TYPE Node is record

Value : INTEGER;

Left, Right : Ptr; end record;

TYPE NumbersArray is ARRAY (1. .SIZE) OF INTEGER;

Numbers : NumbersArray;

TreeRoot : Ptr; dummy : CHARACTER;

PROCEDURE Create is J : INTEGER := 1;

BEGIN

WHILE J <* SIZE LOOP

IF (J >= l) AND (J< 251) THEN Numbers(J) := J;

ELSIF (J > 250) AND (J < 501) THEN Numbers (J) :=SIZE-J;

ELSIF (J > 500) AND (J < 750) THEN Numbers(J) := J;

ELSE

Numbers (J) :=SIZE-J;

END IF;

J := J + 1;

PUT(INTEGER'IMAGE(J) &" ");

END LOOP; new_line;

END Create;

PROCEDURE Insert(Root : in out Ptr; Item : INTEGER) is

— Insert element in binary tree

BEGIN

IF Root = null THEN Root := new Node;

Root.Value :■ Item;

Root.Left :« null;

Root.Right := null;

ELSE

IF Item< Root.Value THEN Insert(Root.Left, Item);

ELSE Insert(Root.Right,Item);

END IF;

END IF;

END Insert;

PROCEDURE Search (Root : in out Ptr; Target : INTEGER) is -- Recursive procedure to search for Target value

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 11

BEGIN

IF not (Root=null) THEN IF not (Target = Root. Value) THEN IF Target < Root .Value THEN Root := Root. Left; Search (Root, Target);

ELSE

Root := Root.Right;

Search(Root,Target);

END IF;

END IF;

END IF;

END Search;

BEGIN — MAIN Create;

PUT_LINE("Created array");

— Building the binary tree

PUT("Press <CR> to time tree creation ");

GET(dummy); NEW.LINE;

TreeRoot ;= null;

FORI INI.. SIZE LOOP Insert(TreeRoot,Numbers(I));

END LOOP;

NEW.LINE;

PUT_LINE( "Created Tree");

PUT("Press <CR> to time tree search ");

GET (dummy); NEVLLINE;

FOR Iter IN 1. .MainLoopCount LOOP FOR I IN reverse 1. .SIZE LOOP Search(TreeRoot,Numbers(I));

END LOOP;

END LOOP;

NEVLLINE;

PUT_LINE("DONE");

END MTPtr;

Listing 8: Source code for Ada Disk Write benchmark program.

with TEXT.IO; use TEXT_IO;

Procedure MTWRITE is

Num_Rec : constant := 512;

Small : STRING(1..30);

Big : STRING(1..120);

F : FILE_TYPE;

BEGIN

Small(l..30) :« "123456781234567812345678123456";

Big : = Small & Small & Small & Small;

CREATE(F, 0UT_FILE, "AjTEMP0.DAT");

FOR I in 1. .Num_Rec LOOP PUT_LINE(F, Big);

END LOOP;

CLOSE(F);

PUT_LINE("DONE");

END MTWRITE;

Listing 9: Source code for Ada Disk Read benchmark program.

with TEXT_I0; use TEXT_I0;

Procedure MTREAD is

Num_Rec : constant :* 512;

Big : STRING(1..120);

Last : NATURAL;

F : FILEJTYPE;

12 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

BEGIN

OPEN(F,IN.FILE,"A:TEMPO.DAT");

FOR I in 1.. Num_Rec LOOP GET_LINE(F, Big, Last);

END LOOP;

CLOSE(F);

PUT_LINE("DONE");

END MTREAD;

DHRY.C Dhrystone benchmark program by Re inhold P. Weicker, translated from Ada by Rick Richardson.

Listing accompanies the article "High-Tech Horsepower" by the BYTE editorial staff, July 1987, page 101. These are standard C language benchmarks used in BYTE reviews.

ft

#

#

#

ft

*

#

#

ft

ft

*

ft

ft

ft

ft

*

*

*

ft

ft

ft

ft

*

ft

ft

#

*

*

*

*

*

ft

ft

ft

ft

ft

ft

ft

ft

EVERBODY: Please read "APOLOGY" below, -rick 01/06/85

See introduction in net.arch, or net.micro

"DHRYSTONE" Benchmark Program

Version:

Date:

Author:

Compile:

Defines:

Run:

Results:

Note:

C/1.1, 12/01/84

PROGRAM updated 01/06/86, RESULTS updated 03/31/86

Reinhold P. Weicker, CACMvol. 27, no. 10, 10/84, pg. 1013 Translated from Ada by Rick Richardson

Every method to preserve Ada likeness has been used, at the expense of C-ness.

cc -0 dry.c -o drynr : No registers

cc -0 -DREG=register dry.c -o dryr : Registers

Defines are provided for old C compilers that don* t have enums and can't assign structures.

The time(2) function is library-dependent; most return the time in seconds, but beware of some, like Aztec C, which return other units. The LOOPS define is initially set for 50,000 loops.

If you have a machine with large integers and is very fast, please change this number to 500,000 to get better accuracy. Please select the way to measure the execution time using the TIME define. For single-user machines, time(2) is adequate. For multiuser machines where you cannot get single-user access, use the times(2) function. If you have neither, use a stopwatch in the dead of night. Use a "printf" at the point marked "start timer" to begin your timings. DO NOT use the Unix time(l) command, as this will measure the total time to run this program, which will (erroneously) include the time to malloc(3) storage and to compute the time it takes to do nothing.

drynr; dryr

If you get any new machine/OS results, please send to: ihnp4!castor!pcrat1 rick

and thanks to all that do. Space prevents listing the names of those who have provided some of these results. I'll be forwarding these results to Re inhold P. Weicker.

I order the list in increasing performance of the "with registers" benchmark. If the compiler doesn't provide register variables, then the benchmark is the same for both REG and N0REG.

* PLEASE:

ft

ft

Send complete information about the machine type, clock speed, OS, and C manufacturer/version. If the machine is modified, tell me what was done. On Unix, execute uname -a and cc -V to get this info.

* 80x8x NOTE: 80x8x benchers: Please try to do all memory models for a particular compiler.

ft

* APOLOGY (1/30/86):

* Well, I goofed things up! As pointed out by Haakon Bugge, the line of code marked "GOOF" below was

* missing from the Dhrystone distribution for the last several months. It #WAS* in a backup copy I made

* last winter, so no doubt it was victimized by sleepy fingers operating vil

ft

* The effect of the line missing is that the reported benchmarks are 15 percent too fast (at least on an

* 80286). Now, this creates a dilemma- -do I throw out ALL the data so far collected and use only results

» from this (corrected) version, or do I Just keep collecting data for the old version?

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 13

*

* Since the data collected so far #is* valid as long as it is compared with like data, I have decided to

a keep TWO lists—one for the old benchmark, and one for the new. This also gives me an opportunity to

a correct one other error I made in the instructions for this benchmark. My experience with C

* compilers has been mostly with Unix 'pcc'-derived compilers, where the 'optimizer* simply fixes

* sloppy code generation (peephole optimization). But today, there exist C compiler optimizers that

a will actually perform optimization in the computer science sense of the word, by removing, for example,

* assignments to a variable whose value is never used. Dhrystone, unfortunately, provides lots of

a opportunities for this sort of optimization.

*

a I request that benchmarkers re-run this new, corrected version of Dhrystone, turning off or bypassing

a optimizers that perform more than peephole optimization. Please indicate the version of Dhrystone

a used when reporting the results to me.

#

a RESULTS BEGIN HERE #

a..DHRYSTONE VERSION 1.1 RESULTS BEGIN..

Table caption*

* MACHINE

MICROPROCESSOR

OPERATING

COMPILER

DHRYSTONES/SEC.

* TYPE

SYSTEM

NO REG

REGS

a Apple He

65C02-1.02 MHz

DOS 3.3

Aztec CII vl.05i

37

37

* .

Z80-2.5 MHz

CPM-80 v2.2

Aztec CII vl.05g

91

91

#

8086-8 MHz

RMX86 V6

Intel C-86 V2.0

197

203LM? ?

a IBM PC XT

8088-4.77 MHz

COHERENT 2.3.43

Mark Williams

259

275

#

8086-8 MHz

RMX86 V6

Intel C-86 V2.0

287

304 ??

* Fortune 32:16

68000-6 MHz

V7+sys3+4.1BSD

cc

360

346

* PDP-11/34A

w/FP-HC

UNIX V7m

cc

406

449

a Macintosh 512

68000-7.7 MHz

Mac ROM 0/S

DeSmet(C ware)

625

625

* VAX-11/750

w/FPA

UNIX 4.2BSD

cc

831

852

a DataMedia 932

68000-10 MHz

UNIX sysV

cc

837

888

a Plexus P35

68000-12.5 MHz

UNIX sysIII

cc

835

894

* ATT PC7300

68010-10 MHz

UNIX 5.0.3

cc

973

1034

a Compaq II

80286-8 MHz

MSDOS 3 • 1

MS C 3.0

1086

1140 LM

a IBM PC AT

80286-7.5 MHz

Venlx/286 SVR2

cc

1159

1254 *15

a Compaq II

80286-8 MHz

MSDOS 3.1

MS C 3.0

1190

1282 MM

a MicroVAX II

Mach/4.3

cc

1361

1385

a DEC uVAX 11

Ultrix-32m vl.l

cc

1385

1399

a Compaq II

80286-8 MHz

MSDOS 3.1

MS C 3.0

1351

1428

# VAX-11/780

UNIX 4.2BSD

cc

1417

1441

a VAX-780/MA780

Mach/4.3

cc

1428

1470

a VAX-11/780

UNIX 5.0.1

cc 4.1.1.31

1650

1640

a Ridge 32C VI

ROS3-3

Ridge C (older)

1628

1695

a Gould PN6005

UTX l.lc-f (4.2)

cc

1732

1884

a Gould PN9080

custom ECL

UTX-321.1C

cc

4745

4992

a VAX-784

Mach/4.3

cc

5263

5555 &4

a VAX 8600

4.3 BSD

cc

6329

6423

a Amdahl 5860

UTS sysV

cc 1.22

28,735

28,846

a IBM3090/200 #

?

?

31,250

31,250

*

*

- DHRYSTONE VERSION 1.0 RESULTS BEGIN..

a MACHINE

MICROPROCESSOR

OPERATING

COMPILER

DHRYSTONES/SEC.

a TYPE

SYSTEM

NO REG

REGS

a Commodore 64

6510-1 MHz

C64 ROM

C Power 2.8

36

36

a HP-110

8086-5.33 MHz

MS-D0S2.il

Lattice 2.14

284

284

a IBM PC XT

8088-4.77 MHz

PC/ IX

cc

271

294

a CCC3205

Xelos(SVR2)

cc

558

592

a Perq-II

2901bltslice

Accent S5c

cc (CMU)

301

301

a IBM PC XT

8088-4.77 MHz

COHERENT 2.3.43

Mark Williams cc

296

317

a Cosmos

68000-8 MHz

UniSoft

cc

305

322

a IBM PC XT

8088-4.77 MHz

Venix/86 2.0

cc

297

324

a DEC PRO 350

11/23

Venix/PRO SVR2

cc

299

325

a IBM PC

8088-4.77 MHz

MS-DOS 2.0

bl6cc 2.0

310

340

a PDP11/23

11/23

Venix (V7)

cc

320

358

a Commodore Amiga

?

Lattice 3.02

368

371

a PC XT

8088-4.77 MHz

Venix/86 SYSV

cc

339

377

a IBM PC

8088-4.77 MHz

MS-DOS 2.0

CI-C86 2.20M

390

390

a IBM PC XT

8088-4.77 MHz

PC-DOS 2.1

Wizard 2.1

367

403

a IBM PC XT

8088-4.77 MHz

PC-D0S 3*1

Lattice 2.15

403

403 @

a ColexDM-6

68010-8 MHz

Unlsoft SYSV

cc

378

410

a IBM PC

8088-4.77 MHz

PC-DOS 3.1

Datalight 1.10

416

416

a IBM PC

NEC V20-4.77 MHz

MS-DOS 3.1

MS 3.1

387

420

a IBM PC XT

8088-4.77 MHz

PC-DOS 2.1

Microsoft 3*0

390

427

14 BYTE LISTINGS SUPPLKMKNT • JULY SEPTEMBER, 1987

* IBM PC

* PDP-11/34

* IBM PC

* Tandy 1000

* Tandy TRS-16B

* PDP-11/34

* Onyx C8002

* Tandy TRS-16B

* DEC PRO 380

* FHLQT+

* Apollo DN550

* HP-110

* ATT PC6300

* IBM PC AT

* Tandy 6000

* IBM PC AT

* Macintosh

* Macintosh

* Macintosh 512

* IBM PC AT

* Codata 3300

* WICATMB

* Cadmus 9000

* AT&T 6300

* Cadmus 9790

* NEC PC9801F

* ATT PC6300

* Burroughs XE550

* EAGLE/TURBO

* ALTOS 586

* DEC 11/73

* ATT 3B2/300

* Apollo DN320

* IRIS-2400

* Atari 520ST

* IBM PC AT

* WICATMB

* VAX-11/750

* CCC7350A

* VAX-11/750

* Fast Mac

* IBM PC XT

* DEC 11/44

* Macintosh

* CCC3210

* ccc 3220

* IBM PC AT

* AT&T 6300

* IBM PC AT

* VAX-11/750

* IBM PC XT

* IBM PC XT

* Plexus P35

* PDP-11/73

* VAX-11/750

* IRIS-1400

* IBM PC AT

* IBM PC AT

* Zilog S8000/11

* NSC ICM-3216

* IBM PC AT

* VAX-11/750

* Stride

* Plexus P/60

* ATTPC7300

* ccc 3230

* Stride

* IBM PC AT

* Plexus P/60

* IBM PC AT

x ATT PC6300+

» IBM PC AT

* Sun 2/120

* IBM PC AT

* WICATPB

NEC V20-4.77 MHz

8088, 4.77MHz V20, 4.77 MHz 68000-6 MHz

Z8000-4 MHz 68000-6 MHz 11/73

68000-10 MHz 68010-? MHz 8086-5.33 MHz 8086-8 MHz 80286-6 MHz 68000-8 MHz 80286-6 MHz 68000-7.8 MHz 2M 68000-7.7 MHz 68000-7.7 MHz 80286-6 MHz 68000-8 MHz 68000-8 MHz 68010-10 MHz 8086-8 MHz 68010-10 MHz 1MB 8086-8 MHz 8086-8 MHz 68010-10 MHz 8086-8 MHz 8086-10 MHz J-ll micro WE32000-? MHz 68010-? MHz 68010-10 MHz 68000-8 MHz 80286-6 MHz 68000-8 MHz

68000-8 MHz

68000-7.7 MHz 8086-9.54 MHz

68000-7.8 MHz 2M

80286-6 MHz 8086, 8 MHz 80286-6 MHz w/FPA

8086-9.54 MHz 8086-9.54 MHz 68000-10 MHz KDJ11-AA 15 MHz w/FPA

68010-10 MHz 80286-6 MHz 80286-6 MHz Z8001-5.5 MHz NSC 32016-10 MHz 80286-6 MHz w/FPA

68000-10 MHz MC68000-12.5 MHz 68010-10 MHz

68000-12 MHz 80286-6 MHz MC68000-12.5 MHz 80286-6 MHz 80286-6 MHz 80286-6 MHz 68010-10 MHz 80286-6 MHz 68000-8 MHz

MS-DOS 3.1 Unix V7M PC-DOS 2.1 MS-D0S2.il Xenix 1.3.5 RSTS/E IS/11.1 (V7) Xenix 1.3.5 Venix/PRO SVR2 Os9/68000 AegisSR9/IX MS-D0S2.il MS-D0S2.il PC-DOS3.0 Xenix 3.0 Xenix 3.0 Mac Rom

Mac ROM 0/S Xenix 3.0 UniPlus+ (v7) System V Unix

Venix/86 SVR2 SVR0,Cadmus3.7 PC-D0S2.il MS-D0S2.il Centix 2.10 Venix/86 SVR2 Xenix 3.0b Ultrix-11 V3.0 Unix 5.0.2 AegisSR9/IX Unix System V TOS

PC-DOS3.0 System V Ultrix 1.1 UniSoft V.2 Unix 4.2bsd

PC-DOS3-1 Ultrix-11 V3.0 Mac Rom

Xelos R01(SVR2) Ed. 7v2.3 Xenix 3.0 MS-D0S2.il Xenix 3.0 Eunice 3*2 PC-DOS3.1 PC-DOS3.1 Unix System III Unix V7M2.1 Unix 4.3bsd Unix System V Venix/86 2.1 PC-DOS 3.0 Zeus 3.2 Unix SVR2 PC-DOS3.0 VMS

System-V/68 Unix SYSIII Unix 5.0.2 Xelos R0l(SVR2) System-V/68 Venix/286 SVR2 Unix SYSIII PC-DOS 3.0 MS-DOS 3.1 PC-DOS 3.1 Sun 4.2BSD PC-DOS3.0 System V

MS 3.1 (186) cc

Aztec C v3.2d Aztec C v3.2d cc

decus c cc

Green Hills cc

version 1.3 cc 3*12 Aztec C bl6cc 2.0 CI-C86 2.1 cc cc

Mac C 32 bit int MegaMax C 2.0 DeSmet(C ware) cc cc

WICAT C 4.1

cc

cc

cc

Lattice 2.15

CI-C86 2.20M

cc

cc

cc

cc

cc

cc 3 • 12 cc

DigResearch MS 3.0(large) WICATC4.1 4.2BSD cc cc cc

MegaMaxC2.0 Microsoft 3*0 cc

Mac C 16 bit int

cc

cc

cc -i

Aztec C v3.2d

cc

cc

Wizard 2.1

Lattice 2.15

cc

cc

cc

cc

cc

bl6cc 2.0

cc

cc

MS 3.0(small) VAX-11C2.0 cc

Plexus

cc

.cc

cc

cc ( ,

Plexus

Datalight 1.10 bl6cc 2.0 Wizard 2.1 cc

CI-C86 2.20M WICATC4.1

393

427

387

438

423

454

423

458

438

458

438

495

476

511

609

617

577

628

603

649 FH

666

666

641

676

632

684

666

684

694

694

684

704 MM

694

704

661

709

714

714

704

714 LM

678

725

585

731

714

735

668

743

720

747

768

- @

769

769

769

769 CT1

696

779

724

793

735

793

735

806

806

806

772

829

839

846

833

847 LM

675

853 S

781

862

821

875

862

877

839

904 +

833

909 Cl

862

909

877

909 S

849

924

892

925

909

925

862

943

892

961

914

976

892

980 Cl

980

980 Cl

984

980

862

981

994

997

909

1000

961

1000

943

1063

1011

1084

1041

1084

1063

1086

958

1091

1041

1111

1111

1111

1041

1111

1040

1126

1063

1136

1056

1149

Ull

1163 T

1190

1190

1111

1219

1136

1219

1136

1219

1219

1219

998

1226

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 15

* MASSCOMP 500

68010-10 MHz

RTU V3.0

cc (V3.2)

1156

1238

* Alliant FX/8

IP (68012-12 MHz)

Concentrix

cc -ip;exec -i

1170

1243 FX

* CybDataMate

68010-12.5 MHz

Uniplus 5.0

Unisoft cc

1162

1250

* PDP 11/70

Unix 5.2

cc

1162

1250

* IBM PC AT

80286-6 MHz

PC-DOS 3*1

Lattice 2.15

1250

1250

* IBM PC AT

80286-7.5 MHz

Venix/86 2.1

cc

1190

1315 *15

* Sun2/120

68010-10 MHz

Standalone

cc

1219

1315

* Intel 380

80286-8 MHz

Xenix R3.0upl

cc

1250

1315 *16

* Sequent Balance 8000

NS32032-10 MHz

Dynix2.0

cc

1250

1315 N12

* IBM PC/DSI-32

32032-10 MHz

MS-DOS 3-1

Green Hills 2.14

1282

1315 C3

* ATT 3B2/400

WE32100-? MHz

Unix 5.2

cc

1315

1315

* CCC 3250XP

Xelos R01(SVR2)

cc

1215

1318

* IBM PC RT 032

RISC(801?)? MHz

BSD 4.2

cc

1248

1333 RT

* DGMV4000

AOS/VS 5.00

cc

1333

1333

• IBM PC AT

80286-8 MHz

Venix/86 2.1

cc

1275

1380 *16

* IBM PC AT

80286-6 MHz

MS-DOS 3.0

Microsoft 3.0

1250

1388

* ATTPC6300+

80286-6 MHz

MS-DOS 3.1

CI-C86 2.20M

1428

1428

* COMPAQ/286

80286-8 MHz

Venix/286 SVR2

cc

1326

1443

* IBM PC AT

80286-7.5 MHz

Venix/286 SVR2

cc

1333

1449 *15

* WICATPB

68000-8 MHz

System V

WICATC 4.1

1169

1464 S

* Tandy 11/6000

68000-8 MHz

Xenix 3.0

cc

1384

1477

* MicroVAX II

Mach/4.3

cc

1513

1536

* WICATMB

68000-12.5 MHz

System V

WICATC 4.1

1246

1537

* IBM PC AT

80286-9 MHz

SCO Xenix V

cc

1540

1556 *18

* CybDataMate

68010-12.5 MHz

Uniplus 5.0

Unisoft cc

1470

1562 S

* VAX-11/780

Unix 5.2

cc

1515

1562

* MicroVAX-II

1562

1612

* VAX-780/MA780

Mach/4.3

cc

1587

1612

* VAX-11/780

Unix 4.3bsd

cc

1646

1662

* Apollo DN660

AegisSR9/IX

cc 3 • 12

1666

1666

* ATT3B20

Unix 5.2

cc

1515

1724

* NEC PC-98XA

80286-8 MHz

PC-DOS 3.1

Lattice 2.15

1724

1724 %

* HP9000-500

B series CPU

HP-UX 4.02

cc

1724

* Ridge 32C VI

ROS3-3

Ridge C(older)

1776

* IBM PC/STD

80286-8 MHz

MS-DOS 3.0

Microsoft 3.0

1724

1785 C2

* WICATMB

68000-12.5 MHz

System V

WICATC 4.1

1450

1814 S

* WICATPB

68000-12.5 MHz

System V

WICATC 4.1

1530

1898

* DEC-2065

KLIO-ModelB

TOPS-20 6.1FT5

Port.C Comp.

1937

1946

* Gould PN6005

UTX1.1(4.1BSD)

cc

1675

1964

* DEC2060

KL-10

T0PS-20

cc

2000

2000 NM

* Intel 310AP

80286-8 MHz

Xenix 3.0

cc

1893

2009

* VAX-11/785

Unix 5.2

cc

2083

2083

^ VAX-11/785

VMS

VAX-11C2.0

2083

2083

* VAX-11/785

Unix SVR2

cc

2123

2083

* VAX-11/785

ULTRIX-32 1.1

cc

2083

2091

* VAX-11/785

Unix 4.3bsd

cc

2135

2136

* WICATPB

68000-12.5 MHz

System V

WICATC 4.1

1780

2233S

* Pyramid 90x

OSx 2.3

cc

2272

2272

* Pyramid 90x

FPA,cache,4Mb

OSx 2.5

cc no -O

2777

2777

* Pyramid 90x

w/cache

OSx 2.5

cc v/-0

3333

3333

* IBM-4341-11

VM/SP3

WaterlooC 1.2

3333

3333

* IRIS-2400T

68020-16.67 MHz

Unix System V

cc

3105

3401

* Celerity C-1200

?

Unix 4.2BSD

cc

3485

3468

* SUN 3/75

68020-16.67 MHz

SUN 4.2 V3

cc

3333

3571

* IBM-4341

Model 12

UTS 5.0

?

3685

3685

* SUN 3/160

68020-16.67 MHz

Sun 4.2 V3.0A

cc

3381

3764

* Sun 3/180

68020-16.67 MHz

Sun 4.2

cc

3333

3846

* IBM-4341

Model 12

UTS 5.0

?

3910

3910 MN

* MC 5400

68020-16.67 MHz

RTU V3.0

cc (V4.0)

3952

4054

# Intel 386/20

80386-12.5 MHz

PMON debugger

Intel C386v0.2

4149

4386

* NCR Tower32

68020-16.67 MHz

SYS 5.0 Rel 2.0

cc

3846

4545

* MC 5600/5700

68020-16.67 MHz

RTU V3.0

cc (V4.0)

4504

4746 %

* Intel 386/20

80386-12.5 MHz

PMON debugger

Intel C386v0.2

4534

4794 11

* Intel 386/20

80386-16 MHz

PMON debugger

Intel C386v0.2

5304

5607

* Gould PN9080

custom ECL

UTX-32 1.1C

cc

5369

5676

^ Gould 1460-342

ECL proc

UTX/32 1.1/c

cc

5342

5677 G1

it VAX-784

Mach/4.3

cc

5882

5882 &4

it Intel 386/20

80386-16 MHz

PMON debugger

Intel C386v0.2

5801

6133 il

it VAX 8600

Unix 4.3bsd

cc

7024

7088

it VAX 8600

VMS

VAX-11C2.0

7142

7142

it Alliant FX/8

CE '

Concentrix

cc -cejexec -c

6952

7655 FX

it CCI POWER 6/32

COS(SV+4.2)

cc

7500

7800

♦t CCI POWER 6/32

POWER 6 Unix/V

cc

8236

8498

* CCI POWER 6/32

4.2 Rel. 1.2b

cc

8963

9544

* Sperry (CCI Power 6)

4.2BSD

cc

9345

10,000

* CRAY-X-MP/12

105 MHz

COS 1.14

Cray C

10,204

10,204

16 BYTE LISTINGS SUPPLEMENT • JULY SEPTEMBER, 1987

ft

IBM-3083

UTS 5.0 Rel 1

cc

16,666

12,500

ft

CRAY-1A

80 MHz

CTSS

CrayC 2.0

12,100

13,888

ft

IBM-3083

VM/CMS HPO 3-4

Waterloo C1.2

13,889

13,889

ft

Amdahl 470 V/8

UTS/V5.2

cc vl.23

15,560

15,560

ft

CRAY-X-MP/48

105 MHz

CTSS

CrayC2.0

15,625

17,857

ft

Amdahl 580

UTS 5.0 Rel 1.2

cc vl.5

23,076

23,076

ft

ft

ft

Amdahl 5860

NOTE

UTS/V5.2

cc vl.23

28,970

28,970

ft

ft

ft

*

ft

ft

ft

ft

ft

*

ft

ft

»

*

ft

ft

ft

ft

ft

ft

ft

ft

ft

ft

ft

ft

ft

ft

ft

ft

ft

ft

ft

ft

ft

ft

ft

ft

ft

ft—

ft

ft

ft

ft

ft

ft

«

ft

ft

ft

ft

ft

ft

x

ft

ft

ft

»/

Table captionft

Table caption+

%

NM

@

S

T

LM

MM

Cl

C 2

C3

C?

CT1

MN

G1

FH

FX

RT

il

Nnn

&nn

Crystal changed from 'stock' to listed value.

This Macintosh was upgraded from 128K to 512K in such a way that the new 384K of memory is not slowed down by video generator accesses.

Single processor; MC == MASSCOMP.

A version 7 C compiler written at New Mexico Tech.

Vanilla Lattice compiler used with MicroPro standard library.

Shorts used instead of ints.

With Chris Torek' s patches (whatever they are).

For WICAT Systems: MB=MultiBus, PB=Proprietary Bus.

Large Memory Model. (Otherwise, all 80x8x results are small model).

Medium Memory Model. (Otherwise, all 80x8x results are small model).

Univation PC TURBO Coprocessor; 9.54-MHz 8086, 640K RAM Seattle Telecom STD-286 board.

Definicon DSI-32 coprocessor.

Unknown coprocessor board.

Convergent Technologies MegaFrame, 1 processor.

Using Mike Newton's 'optimizer' (see net.sources).

This Gould machine has two processors and was able to run two Dhrystone benchmarks in parallel with no slowdown.

FHC == Frank Hogg Labs (Hazelwood Uniquad 2 in an FHL box).

The Alliant FX/8 is a system consisting of 1-8 CEs (computation engines) and 1-12 IPs (interactive processors). Note N8 applies.

This is one of the RTs that CMU has been using for awhile. I'm not sure that this is identical to the machine that IBM is selling to the public.

Normally, the 386/20 starter kit has a 16K direct-mapped cache, which inserts two or three wait states on a writethrough. These results were obtained by disabling the write-through, or essentially turning the cache into zero-wait-state memory.

This machine has multiple processors, allowing "nn" copies of the benchmark to run in the same time as one copy.

This machine has "nn" processors, and the benchmark results were obtained by having all "nn" processors working on one copy of Dhrystone. (Note this is different than Nnn. Salesmen like this measure.)

I don't trust results marked with ' ?'. These were sent to me with either incomplete info, or with times that Just don't make sense. ?? means I think the performance is too poor; ?! means too good. If anybody can confirm these figures, please respond.

ABBREVIATIONS

CCC

MC

Concurrent Computer Corp. (was Perkin-Elmer) Masscomp

-RESULTS END

The following program contains statements of a high-level programming language (C) in a distribution considered representative:

assignments 53JK

control statements 32 %

procedure, function calls 15!C

100 statements are dynamically executed. The program is balanced with respect to the three aspects:

- statement type

- operand type (for simple data types)

- operand access

operand global, local, parameter, or constant.

The combination of these three aspects is balanced only approximately.

The program does not compute anything meaningful, but it is syntactically and semantically correct.

/# Accuracy of timings and human fatigue controlled by next two lines */

^define LOOPS 50000 /# Use this for slow or 16-bit machines #/

/*#define LOOPS 500000 /# Use this for faster machines #/

continued

BYTE-LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 17

/* Compiler-dependent options */

tfundef NOENUM /* Define if compiler has no enums */

tfundef NOSTRUCTASSIGN /* Define if compiler can't assign structures */

/# define only one of the next two defines #/

I *#define TIMES /* Use times(2) time function #/

^define TIME /* Use time(2) time function #/

/* define the granularity of your times(2) function (when used) #/

^define HZ 60 /* times(2) returns 1/60 second (most) */

/*#define HZ 100 /* times(2) returns 1/100 second (WECo) #/

/* for compatibility with goofed-up version */

/x#define GOOF /* Define if you want the goofed-up version */

tfifdef GOOF

char Vers ion [ ] * "1.0";

0else

char Vers ion [ ] = "1.1";

#endif

tfifdef

NOSTRUCTASSIGN

^define

structassign(d, s)

0else

^define

structassign(d, s)

tfendif

0ifdef

NOENUM

^define

Identl

1

^define

Ident2

2

^define

Ident3

3

^define

Ident4

4

^define

Identl

5

typedef

tfelse

int

Enumeration;

typedef

rfendif

enum

{Identl, Ident2

memcpy(&(d), &(s), sizeof(d)) d = s

Ident3, Ident4, Ident5} Enumeration;

typedef

int

OneToThirty;

typedef

int

OneToFifty;

typedef

char

CapitalLetter;

typedef

char

String30[31];

typedef

int

ArraylDim[51];

typedef

int

Array2Dim[51][51];

struct

Record

{

struct Record

Enumeration

Enumeration

OneToFifty

String30

};

typedef struct Record RecordType; typedef RecordType # RecordPtr; typedef int boolean;

/* #deflne NULL 0*1

^define TRUE 1

^define FALSE 0

*PtrComp;

Discr;

EnumComp;

IntComp;

StringComp;

#ifndef REG ^define REG rt/endif

extern Enumeration Funcl(); extern boolean Func2();

0include <HD20:C:^include files: stdio.h>

0ifdef TIMES

^include <HD20:C:#include files:unix ^includes: types.h> ^include <HD20:C:#include files:unix ^includes: time.h> 0endif

18 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1987

main()

{

ProcO(); exit(O);

}

1*

* Package 1

»/

int

IntGlob;

boolean

BoolGlob;

char

CharlGlob;

char

Char2Glob;

ArraylDim

ArrayIGlob;

Array2Dim

Array2Glob;

RecordPtr

PtrGlb;

RecordPtr

PtrGlbNext;

Proc0()

{

OneToFifty REG OneToFifty OneToFifty REG char REG char Enumeration String30 String30 extern char

tfifdef TIME

long

long

long

long

register unsigned int

IntLocl; IntLoc2; IntLoc3; CharLoc; CharIndex; EnumLoc; StringlLoc; String2Loc; #malloc();

time();

starttime;

benchtime;

nulltime;

l;

starttime=time( (long*)0); for (i = 0; i< LOOPS;++i);

nulltime = time( (long #) 0) - starttime; /# Computes o'head of loop #/

tfendif 0ifdef TIMES

time_t time_t time_t struct tm

register unsigned int

starttime;

benchtime;

nulltime;

tms;

i;

times(&tms); starttime = tms.tms_utime; for (i = 0; i< LOOPS; ++i); times(&tms);

nulltime = tms.tms_utime - starttime; /# Computes overhead of looping #/

tfendif

PtrGlbNext = (RecordPtr) malloc(sizeof(RecordType));

PtrGlb = (RecordPtr) malloc(sizeof(RecordType)); PtrGlb->PtrComp » PtrGlbNext;

PtrGlb->Discr= Identl;

PtrGlb->EnumComp = Ident3;

PtrGlb->IntComp = 40;

s trcpy (PtrGlb->StringComp, "DHRYSTONE PROGRAM, SOME STRING");

^ifndef GOOF

strcpy(StringlLoc, "DHRYSTONE PROGRAM, 1ST STRING"); /#G00F#/

*endif

Array2Glob[8] [7] = 10; /# Was missing in published program */

/ft*******************

— Start Timer —

########/

0ifdef TIME

starttime »time( (long #) 0);

He ndif tflfdef TIMES

times(&tms); starttime = tms.tms_utime;

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 19

#endif

for (i = 0; i< LOOPS; ++1)

{

Proc5();

Proc4();

IntLocl=2;

IntLoc2 = 3;

strcpy (String2Loc, "DHRYSTONE PROGRAM, 2ND STRING"); EnumLoc = Ident2;

BoolGlob = ! Func2(StringlLoc, String2Loc); while (IntLocl < IntLoc2)

{

IntLoc3 * 5 * IntLocl - IntLoc2;

Proc7(IntLocl, IntLoc2, &IntLoc3);

•H-IntLocl;

}

Proc8(ArrayIGlob, Array2Glob, IntLocl, IntLoc3); Procl(PtrGlb);

for (Charlndex = 'A'; Charlndex<= Char2Glob; ++Charlndex) if (EnumLoc == Fund(Charlndex, *C *)) Proc6(Identl, &EnumLoc);

IntLoc3 = IntLoc2 # IntLocl;

IntLoc2 = IntLoc3 / IntLocl;

IntLoc2 = 7 # (IntLoc3 - IntLoc2) - IntLocl; Proc2(&IntLocl);

/

Stop Timer

- /

/Hifdef TIME

benchtime =» time( (long *) 0) - starttime - nulltime; printf("Dhrystone(Jts) time for *ld passes -%l\ n",

Version,

(long) LOOPS, benchtime);

printf ("This machine benchmarks at Xld Dhrystones/second \ n", ((long) LOOPS) / benchtime);

0endif /Kifdef TIMES

times(&tms);

benchtime = tms.tms_utime - starttime - nulltime; printf("Dhrystone(*s) time for %ld passes * *ld\ n",

Version,

(long) LOOPS, benchtime/HZ);

printf ("This machine benchmarks at *ld Dhrystones/second \ n", ((long) LOOPS) * HZ / benchtime);

tfendif

}

Procl(PtrParln)

REG RecordPtr PtrParln;

{

0defineNextRecord (#(PtrParIn->PtrComp))

structassign(NextRecord, *PtrGlb);

PtrParIn->IntComp = 5;

NextRecord.IntComp = PtrParIn->IntComp;

NextRecord.PtrComp = PtrParIn->PtrComp;

Proc3(NextRecord.PtrComp); if (NextRecord.Discr « Identl)

{

NextRecord.IntComp = 6;

Proc6(PtrParIn->EnumComp, &NextRecord.EnumComp); NextRecord.PtrComp = PtrGlb->PtrComp;

Proc7(NextRecord.IntComp, 10, &NextRecord.IntComp);

}

else

structassign(#PtrParIn, NextRecord);

0undef NextRecord

}

20 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

Rroc2(IntParI0)

OneToFifty •IntParlO;

{

REG OneToFifty IntLoc;

REG Enumeration EnumLoc;

IntLoc = *IntParIO + 10; for(;;)

{

If (CharlGlob == 'A')

{

—IntLoc;

•IntParlO =IntLoc - IntGlob; EnumLoc = Identl;

}

if (EnumLoc == Identl)

break;

}

}

Proc3(PtrPar0ut)

RecordPtr #PtrParOut;

{

If (PtrGlb ! = NULL)

•PtrParOut = PtrGlb->PtrComp;

else

IntGlob = 100;

Proc7(l0, IntGlob, &PtrGlb->IntComp);

}

Proc4()

{

REG boolean BoolLoc;

BoolLoc = CharlGlob == 'A';

BoolLoc | = BoolGlob;

Char2Glob = 'B';

}

Proc5()

{

CharlGlob = 'A'; BoolGlob = FALSE;

}

extern boolean Func3();

Proc6(EnumParIn, EnumParOut) REG Enumeration EnumParIn; REG Enumeration •EnumParOut;

{

}

•EnumParOut * EnumParln; if (! Func3(EnumParln) )

•EnumParOut = Ident4; switch (EnumParln)

{

case Identl: case Ident2:

case Ident3: case Ident4: case Ident5: }

•EnumParOut * Identl; break; if (IntGlob > 100) •EnumParOut * Identl; else •EnumParOut = Ident4; break;

•EnumParOut * Ident2; break; break;

•EnumParOut = Ident3;

Proc7(IntParIl, IntParI2, IntParOut)

OneToFifty IntParll;

OneToFifty IntParI2;

OneToFifty •IntParOut;

{

REG OneToFifty IntLoc;

IntLoc = IntParll+ 2;

• IntParOut * IntParI2 + IntLoc;

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 21

}

Proc8(ArrayIPar, Array2Par, IntParll, IntParI2)

ArrayIDim ArraylPar;

Array2Dim Array2Par;

OneToFifty IntParll;

OneToFifty IntParI2;

{

REG OneToFifty IntLoc;

REG OneToFifty IntIndex;

IntLoc = IntParll + 5;

ArraylPar[IntLoc] =IntParI2;

ArraylPar[IntLoc+1] = ArraylPar[IntLoc];

ArraylPar[IntLoc+30] =IntLoc;

for (Intlndex = IntLoc; Intlndex<= (IntLoc+1); ++Intlndex) Array2Par[IntLoc][IntIndex] =IntLoc;

++Array2Par[IntLoc][IntLoc-1];

Array2Par[IntLoc+20][IntLoc] = ArraylPar[IntLoc];

IntGlob = 5;

}

Enumeration Fund (Char Pari, CharPar2)

CapitalLetter CharParl;

CapitalLetter CharPar2;

{

REG CapitalLetter CharLocl;

REG CapitalLetter CharLoc2;

}

CharLocl= CharParl; CharLoc2 = CharLocl; if (CharLoc2 != CharPar2) return (Identl);

else

return (Ident2);

boolean Func2(StrParIl, StrParI2)

String30 StrParll;

String30 StrParI2;

{

REG OneToThirty IntLoc;

REG CapitalLetter CharLoc;

}

IntLoc = 1; while (IntLoc<= 1)

if (Funcl(StrParIl[IntLoc], StrParI2[IntLoc+1]) == Identl)

{

CharLoc « 'A';

++IntLoc;

}

if (CharLoc >- 'W* && CharLoc <» 'Z')

IntLoc = 7; if (CharLoc == 'X') return(TRUE);

else

{

if (strcmp(StrParIl, StrParI2) > 0)

{

IntLoc += 7; return (TRUE);

}

else

}

return (FALSE);

boolean Func3(EnumParIn)

REG Enumeration EnumParln;

{

REG Enumeration EnumLoc;

EnumLoc = EnumParln;

if (EnumLoc »■ Ident3) return (TRUE);

return (FALSE);

22 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

H ifde f NOSTRUCTASSIGN

rnemcpy(d, s, 1)

register char

*d;

register char

*s;

register int

{

while

}

l;

(1—) *d++

Table captiontfendif

FIB.C Accompanies the article "High-Tech Horsepower" by the BYTE editorial staff, July 1987, page 101. These are standard C language benchmarks used in BYTE reviews.

^include <stdio.h>

^define NTIMES 10/* number of times to compute Fibonacci value */ ^define NUMBER 24/* biggest one we can compute with 16 bits */

main()

/* compute Fibonacci value */

{

int i;

unsigned value, fib();

printf("*d iterations: ", NTIMES);

for (i ■ 1; i<= NTIMES; i++) value = fib(NUMBER);

printf( "Fibonacci Jd) = j(u.\n", NUMBER, value); exit(0);

}

unsigned fib(x)

/* compute Fibonacci number recursively */

int x;

{

if (x > 2)

return (fib(x - 1) + fib(x - 2));

else

return (1);

}

FLOAT.C Accompanies the article "High-Tech Horsepower" by the BYTE editorial staff, July 1987, page 101. These are standard C language benchmarks used in BYTE reviews.

/* simple benchmark for testing floating-point speed of c libraries does repeated multiplications and divisions in a loop that is large enough to make the looping time insignificant */

^define C0NST1 3-141597E0 ^define C0NST2 1.7839032E4 ^define COUNT 10000

main()

{

double a, b, c; int i;

a = C0NST1; b * C0NST2;

for (i ■ 0; i< COUNT; ++i)

{

c = a * b;

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 23

c * c/ a; c = a * b; c = c/ a; c = a # b; c ■ c/ a; c = a * b; c = c/a; c = a * b; c = c/ a; c = a*b; c = c/ a; c = a # b; c = c/a;

}

printf ("Done\n");

}

SORT.C Accompanies the article "High-Tech Horsepower" by the BYTE editorial staff, July 1987, page 101. These are standard C language benchmarks used in BYTE reviews.

/# sorting benchmark- -calls randomly the number of times specified by MAXNUM to create an array of long integers, then does a quicksort on the array of longs. The program does this for the number of times specified by COUNT.

*/

^include "stdlo.h"

^define MAXNUM 1000 ^define COUNT 10

^define MODULUS ((long) 0x20000)

^defineC13849L ^define A25173L

long seed = 7L;

long random ();

long buffer [MAXNUM] = {0};

main()

{

int i, J; long temp;

/*

^include "startup.c"

*/

printf ("Filling array and sorting %6 times\n", COUNT); for (i = 0; i< COUNT; ++i)

{

for (J =0; J < MAXNUM; ++J)

{

temp = random (MODULUS); if (temp< 0L)

temp = (-temp); buffer[J] = temp;

}

printf ("Buffer full, iteration Jfd\n", i); quick (0, MAXNUM - 1, buffer);

}

/»

^include "done.c"

*/

}

quick (lo, hi, base) int lo, hi; long base [ ];

{

24 BYTE LISTINGS SUPPLEMENT • JULY SEPTEMBER, 1987

July

int i, j;

long pivot, temp; if (lo< hi)

for (i = lo, j = hi-1, pivot = base [hi]; i < j; )

{

while (i < hi && base [i] <= pivot)

•f+i;

while (j > lo && base [j ] >= pivot)

J i

if (i<J)

{

temp = base [i]; base [i] = base [j]; base [j] = temp;

}

}

temp = base [i]; base [i] = base [hi]; base [hi] = temp; quick (lo, i - 1, base); quick (i + 1, hi, base);

}

}

long random (size) long size;

{

seed = seed * A + C; return (seed % size);

)

SIEVE.C Accompanies the article "High-Tech Horsepower" by the BYTE editorial staff, July 1987, page 101. These are standard C language benchmarks used in BYTE reviews.

/*

Eratosthenes Sieve prime-number program in from BYTE January 1983 */

^define TRUE 1 ^define FALSE 0 ^define size 8190

char flags [size + 1]; main()

{

int i, prime, k, count, iter;

}

printf ("10 iterations\n"); for (iter = 1; iter<= 10; iter++) {

count * 0;

for (1 = 0; i < = size; i++) flags [i] = TRUE; for (i = 0; i <= size; i++)

/# do program 10 times #/

/# prime counter #/

/# set all flags true #/

{

if (flags [i]) /« found a prime #/

{

prime = i + i + 3# /# twice index + 3 *1

I* printf ("\n*d", prime); */ for (k»i + prime; k<= size; k+= prime)

flags [k] = FALSE; /# kill all multiple #/

count-H*; I* primes found */

}

}

printf ("tfd primes.\n", count); /# primes found on 10th pass #/

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 25

SAVAGE.C Accompanies the article "High-Tech Horsepower" by the BYTE editorial staff, July 1987, page 101. These are standard C language benchmarks used in BYTE reviews.

/*

** savage.c — floating-point speed and accuracy test. C version ** derived from BASIC version that appeared in Dr. Dobb's Journal, ** Sept. 1983, pp. 120-122.

*/

^define

I LOOP

2500

extern

double

main()

{

int i;

tan(), atan(), exp(), log(), sqrt();

double a;

printf("start\n"); a = 1.0;

for (i«l; i<= (IL00P-1); i++) a = tan(atan(exp(log(sqrt(a#a)))))+1.0; printf("a = *20.l4e\n", a); printf("done\n");

Table caption}

FILEIO.C Accompanies the article "High-Tech Horsepower" by the BYTE editorial staff, July 1987, page 101. These are standard C language benchmarks used in BYTE reviews.

/# file reading and writing benchmark

sequentially writes a 65,000-byte file on disk generates random long numbers

uses these modulo 65,000 to read and write strings of 0DDNUM bytes with the file-handling system of the c package the random-number generator is set to a specific seed, so that all compilers should generate the same code

*/

^define ERROR -1 ^define READERR 0

^define BEG 0 ^define CURR 1 ^define END 2 ^define READ0 /I/define WRITE 1 ^define UPDATE 2

^define 0KCL0SE 0 ^define FILESIZE 65000L ^define COUNT 500

^defineC 13849L ^define A 25173L ^define 0DDNUM 23 long seed * 7L;

long random (), lseek ();

main ()

{

int i;

long J, pos; int fd;

char buffer [0DDNUM + 1];

26 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

if ((fd = creat ("test.dat", WRITE)) == ERROR) abort ("Can't create data file\n"); else printf ("File opened for sequential writing\n"); for (J = 0; j < FILESIZE; ++J)

if (write(fd, "x", 1) == ERROR)

abort ("Unexpected EOF in writing data file\n"); if (close (fd) ! = OKCLOSE)

abort ("Error closing data file\n");

else

printf ("Normal termination writing data file\n"); if ((fd = open ("test.dat", UPDATE)) == ERROR)

abort ("Can't open data file for random reading and writing\n"); else printf ("File opened for random reading and writing\n"); for (i = 0; i< COUNT; ++i)

{

J = random (FILESIZE); if (J < 0L)

J =(-J);

if (FILESIZE - j < ODDNUM) continue;

if ((pos = lseek (fd, j, BEG)) == -1L)

abort ("Error reading at random offset\n"); if (read (fd, buffer, ODDNUM) « READERR)

abort ("Error reading at random offset\n"); j = random (FILESIZE); if (J < 0L)

J = (-J);

if (FILESIZE-J< ODDNUM) continue;

if ((pos = lseek (fd, J, BEG)) « -1L)

abort ("Error seeking to random offset\n"); if (write (fd, buffer, ODDNUM) == READERR)

abort ("Error writing at random offset\n");

if (close (fd) != OKCLOSE)

abort ("Error closing data file\n");

else

printf ("Normal termination from random reading and writing\n");

long random (size) long size;

{

seed = seed # A + C; return (seed % size);

}

abort (message) char ^message;

{

printf (message); exit (ERROR);

}

WHET.C Accompanies the article "High-Tech Horsepower" by the BYTE editorial staff, July 1987, page 101. These are standard C language benchmarks used in BYTE reviews.

/*

From hplabsIsdcrdcf!sdcsvax!dcdwest!ittatc!decvax!mcnc!rti-sel!scirtp!dfh Sun Aug 25 12:55:29 1985

Relay-Version: version B 2.10.2 9/18/84; site amdahl.UUCP

Pos t ing-Vers ion: vers ion B 2.10.2 9/ 5 / 84; s i te sc irtp. UUCP

Path: amdahl!hplabsIsdcrdcf!sdcsvax1dcdwest1ittatc!decvax!mcnclrti-selIscirtp!dfh From: dfhgscirtp.UUCP (David F. Hinnant)

Newsgroups: net.sources

Subject: Whetstone benchmark source in C - enclosed Mcssage-ID:<353@scirtp.UUCP>

Date: 25 Aug 85 19:55:29 GMT

Date Received: 27 Aug 85 08:15:18 GMT

Distribution: net

Organization: SCI Systems, Research Triangle Park, NC

Lines: 252 continued

BYTE LISTINGS SUPPLEMENT

JULY-SEPTEMBER, 1987 27

Enclosed below is a C translation of the famous "Whetstone benchmark" from the original Algol version. I have inserted printf () as a compiler option. I think this translation is accurate. The only

listing accompanies the article "High-Tech Horsepower" by the BYTE editorial staff, July 1987, page 101. These are standard C language benchmarks used in BYTE reviews.

Numbers I have to compare with are from an old Ridge-32 machine, and these are from a Pascal translation (I caught one error in their translation). If anyone has any numbers from FORTRAN, Pascal, or Algol versions of the Whetstone, I would very much like to see them.

David Hinnant SCI Systems Inc.

{decvax, akgua} !mcnc!rti-sel!scirtp!dfh P.S. There is a .signature file at the end of the listing. #/

11 ............

/*

ft Whetstone benchmark in C. This program is a translation of the ft original Algol version in "A Synthetic Benchmark" by H. J. Curnow ft and B. A. Wichman in Computer Journal, vol. 19, no. 1, February 1976.

*

ft Used to test compiler optimization and floating-point performance.

ft

* Compile by: cc-0-s-o whet whet.c ft or: cc -0 -DP0UT -s -o whet whet. c ft if output is desired.

»/

^define ITERATIONS 10 /* 1 million Whetstone instructions */

#include "sane.h"

^include "stdio.h"

II ^Options G H

^define POUT

^define Pout(n, J, k, xl, x2, x3, x4) timingOff;\ pout(n, j, k, xl, x2, x3, x4);timing0n #def ine double extended ^define tickCount #((long #)0xl6A)

^define timingOn ticks -* tickCount ^define timingOff ticks += tickCount

double xxl, xx2, xx3, xx4, x, y, z, t, tl, t2; double el[4];

int i, J, k, 1, nl, n2, n3, n4, n6, n7, n8, n9, nlO, nil; long ticks;

main()

{

printf("\nWhetstone Benchmark\n\n");

ticks * 0;

timingOn;

/# initialize constants #/

t *0.499975; tl* 0.50025; t2 * 2.0;

I* set values of module weights #/

nl*0# ITERATIONS; n2 * 12 # ITERATIONS; n3 a 14 # ITERATIONS; n4 * 345 * ITERATIONS; n6* 210 * ITERATIONS; n7 * 32 # ITERATIONS; n8 * 899 » ITERATIONS; n9 - 616 # ITERATIONS; nlO * 0 # ITERATIONS; nil * 93 * ITERATIONS;

/# MODULE 1: simple identifiers #/

28 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

July

xxl=1.0;

xx2 = xx3 = xx4 = -1.0;

for(i = 1; i<= nl; i+= 1) { xxl = ( xxl + xx2 + xx3 - xx4 ) # t; xx2 = ( xxl + xx2 - xx3 - xx4 ) * t; xx3 = ( xxl - xx2 + xx3 + xx4 ) * t; xx4 = (-xxl + xx2 + xx3 + xx4 ) # t;

}

0ifdef POUT

Pout(nl, nl, nl, xxl, xx2, xx3, xx4); tfendif

/# MODULE 2: array elements #/ el[0] =1.0;

el[l] = el[2] = el[3] =-1.0;

for (1 = 1; i <= n2; i+=1) { el[0] = ( el[0] + el[l] + el[2] - el[3] ) * t; el[l] = ( el[0] + el[l] - el[2] + el[3] ) * t; el[2] = ( el[0] - el[l] + el[2] + el[3] ) * t; el[3] = (-el[0] + el[l] + el[2] + el[3] ) * t;

#ifdef POUT

Pout(n2, n3, n2, el[0], el[l], el[2], el[3]); tfendif

/# MODULE 3: array as parameter #/

for (1 = 1; 1 <= n3; i+= 1) pa(el);

#ifdef POUT

Pout(n3, n2, n2, el[0], el[l], el[2], el[3]); tfendif

/# MODULE 4: conditional Jumps #/

J = i;

for (1 = 1; 1 <= n4; 1 += 1) {

if (J a =D

J = 2; else JOl

if (J>2)

J = 0; else

J a 1;

if (J <1)

J -l;

else J = 0;

}

#ifdef POUT

Pout(n4, J, J, xxl, xx2, xx3, xx4); ^endif

/* MODULE 5: omitted */

/# MODULE 6: integer arithmetic #/

J = i; k = 2; 1-3;

for (i = 1; i <= n6; i += 1) {

J s J # (k-J) * (1-k);

k = l*k-(l-J) *k; l.(l-k)»(k + J);

el[l - 2] ■ J + k + 1; /# C arrays are zero-based */

el[k - 2] = J * k * 1;

}

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 29

tfifdef POUT

Pout(n6, J, k, el[0], el[l], el[2], el[3]); #endif

/# MODULE 7: trig, functions */ x = y = 0.5;

for(i = 1; i <= n7; i+=l) {

x = t * atan(t2*sin(x)*cos(x)/(cos(x+y)+cos(x-y)-1.0)); y = t * atan(t2#sin(y)*cos(y)/(cos(x+y)+cos(x-y)-l*0));

}

#ifdef POUT

Pout(n7, J > k> x, x, y, y);

0endif

/# MODULE 8: procedure calls #/

x = y = z = 1.0;

for (1*1; i<=n8; i+=l)

P3(x, y, &z); tfifdef POUT

Pout(n8, J, k, x, y, z, z);

0endif

/# MODULE 9: array references */

J -U

k = 2;

1*3?

el[0] =1.0; el[l] =2.0; el[2] =3.0;

for(i = 1; i <= n9; i+= 1)

POO?

#ifdef POUT

Pout(n9, J, k, el[0], el[l], el[2], el[3]); 0endif

/# MODULE 10: integer arithmetic #/

J =2; k = 3?

for(i = 1; i<= nlO; i +=1) {

J = J + k; k = J +k;

J *k- J; k = k-J - J;

}

#lfdef POUT

Pout(nlO, j, k, xxl, xx2, xx3> xx4);

0endif

/# MODULE 11: standard functions #/ x * 0.75;

for(i = 1; i <= nil; i+=l) x = sqrt( exp( log(x) / tl));

#ifdef POUT

Pout(nll, J, k, x, x, x, x); tfendif

timingOFF;

printf("\nWhetstone runs in *0.2f seconds. #0.2f whets/second\n" tlcks/60.0, 60000000.0/ticks); getchar(); exit(O);

}

30 BYTE LISTINGS SUPP1.F.MENT • JULY-SEPTEMBER, 1987

pa(e)

double e[4];

{

register int j;

J =0; lab:

e[0] . ( e[0] + e[l] + e[2] - e[3J ) * t;

e[l] ' ( e[0] + e[l] - e[2] + e[3] ) * t;

e[2] = ( e[0] - e[l] + e[2] + e[3] ) * t;

e[3] = ( -e[0] +e[l] +e[2] +e[3] ) /12;

J +»1; if (J < 6)

goto lab;

P3(x, y, z) double x, y, *z;

{

x = t* (x + y); y = t* (x + y); »z = (x + y) /t2;

}

POO

{

el[J] -el[k); el[k] «el[l]j el[l] ■ el[J];

}

#ifdefPOUT

pout(n, J, k, xl, x2, x3, x4)

int n, j, k;

double xl, x2, x3, x4;

{

printf ("*5d *5d *11.3e *11.Je tll.Je *11.3e\n",

n, J, k, xl, x2, x3, x4);

}

tfendif

/»

David Hinnant SCI Systems Inc.

{decvax, akgua} !mcnc!rti-sel!scirtp!dfh

*/

USORT.PAS Program in Turbo Pascal 3*0 for the IBM PC and compatibles. From the article "Focus on Algorithms: Sorting out the Sorts" by Dick Pountain, July 1987, page 275.

program USORT;

const CR = H 13; { carriage return character }

type letters = ' a'.. * z'; wordtype = string[l6]; nodeptr* "nodetype; nodetype = record info: wordtype; next: nodeptr end;

var inputFile,outputFile: text;

inputFilename, outputFilename: string[127]; chr,firstletter: char;

sortList: array [letters] of nodeptr; { the array of 26 lists } i: letters; word: wordtype; procedure InitFiles; begin { open input and output files }

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 31

inputFilename := paramSTR(l);

Assign(inputFlle,inputFilename);

Reset(inputFile); outputFilename := paramSTR(2);

Assign(outputFile, outputFilename);

Rewrite(outputFile); end;

procedure GetWord(VAR inFile: text; VAR word: wordtype); begin { read a cleaned-up word from the input file } word := ''; { initialize to blank }

repeat

read(infile,chr);

if chr in [' A'.. *Z 1 ] { convert all to lowercase }

thenchr : = char(ord(chr)+32);

if chr in [ 1 a 1 .. * z' ] { only accept alpha characters }

then word : = word+chr; { add to word being built} until (chr = ' ') or (chr = CR) or eof(infile) end;

procedure Place (VAR list: nodeptr; word: wordtype); var p,q,newnode: nodeptr; found: boolean;

begin { insert new word into list in sorted position only if unique } q : = nil;

p:=list; { p points to head of list) found : = false;

while (p<> nil) { not end of list and } and (not found) { word not already here and }

and (word >= p*. info) do { word alphabetically later than current} if p*. info = word { does this node contain our word? } then found : = true { yes! word is already here ) else begin

q : = p; { remember this node and } p : = p* .next { move on to the next one } end; {while}

if not found { word isn' t already here } then begin

New(newnode); { create a new node }

newnode*. info : = word; { put word in its info field }

ifq = nil { list was empty }

then begin

newnode* .next := list; { newnode becomes first} list := newnode end

else begin

newnode*.next :*q“.next; { insert after node q } q*.next := newnode end end end;

procedure SquirtOut(list: nodeptr; VARoutflle: text); begin { send sorted list to output file } while list <> nil begin

writeln(outfile,list*.info); list := list*.next end end;

begin { main program }

InitFiles;

for i := 1 a' to 'z' do sortList[i] :« nil; { initialize all the lists }

while not eof (inputFile) do

begin

GetWord(inputFile,word); firstletter :* word[l]; { get first letter }

Place(sortList[firstletter] ,word) { put word in proper place } end; {while}

fori := 'a' to 'z f doSquirtOut(sortList[i],outputFile); writeln('Keywords are contained in ',outputFilename);

Close(inputFile);

Close(outputFile)

end.

32 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

LISTING2.TXT Contributed by David Gedeon. Accompanies "Programming Insight: Complex Math in Pascal," July 1987, page 121.

{$INCLUDE:'complex.int'}

IMPLEMENTATION OF complex;

TYPE

stackpt = "stack; stack = RECORD

r, i: REAL; {Holds real and imaginary parts of number} next,prev: stackpt; {Links RECORDS of stack}

END;

VAR zpt,zroot: stackpt; {variable stack pointer and root position}

PROCEDURE push; {increments stack pointer; creates new RECORD only if next position = NIL}

VARzsav: stackpt;

BEGIN

IF (zpt".next <> NIL) THEN zpt:* zpt".next ELSE BEGIN zsav:= zpt;

NEW(zpt);

zpt" .prev:= zsav; zpt".next:* NIL; zsav" .next:= zpt;

END;

END;

PROCEDURE pop; {Decrements stack pointer}

BEGIN

IF (zpt".prev<> NIL) THEN zpt:= zpt".prev ELSE BEGIN {In case of no previous element, pop zeros} zpt".r:=0.0; zpt".i:=0.0;

END;

END;

FUNCTION display: {Argument (indx: INTEGER) declared in interface; extracts real or imaginary parts of current stack pointee} BEGIN

CASE indx OF 1: display:= zpt".r;

2: display:= zpt".i;

OTHERWISE display:* 0;

END;

END;

PROCEDURE keyin; {Argument (z: cmplx) declared in interface; equivalent of keying in numbers on calculator; pushes stack, inserts number at new pointee}

BEGIN

push;

zpt".r:= z[l]; zpt".i:* z[2]j

END;

PROCEDURE rkeyin; {Argument (x: REAL) declared in interface}

{Similar to KEYIN except enters real number}

BEGIN

push;

zpt".r:* x; zpt".i:* 0.0;

END;

PROCEDURE enter; {Copies current pointee onto stack}

VAR a,b: REAL;

BEGIN

a:* zpt".r; b:= zpt".i; push;

zpt".r:=a; zpt".i:*b;

END;

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 33

PROCEDURE clear; {Resets stack pointer to root of list, zeros}

BEGIN

zpt:= zroot;

zpt A .r:=0.0; zpt A .i: = 0.0;

END;

PROCEDURE negate; {Negative of current stack polntee}

BEGIN

zpt" .r: = -zpt A .r; zpt A .i:= -zpt A .i;

END;

PROCEDURE conjugate; {Complex conjugate of current stack pointee}

BEGIN

zpt A .i:» - zpt A .i;

END;

PROCEDURE invert; {inverse of current stack pointee}

VAR mag: REAL;

BEGIN

mag: = (zpt A .r * zpt A .r) + (zpt A .i * zpt A .i); zpt A .r:= zpt A .r/ mag; zpt A . i:= -zpt A . i / mag;

END;

PROCEDURE add; {Adds current and previous stack pointees; pops stack; result in new pointee} VAR a,b: REAL;

BEGIN

a: = zpt A .r; b: = zpt A .i; pop;

zpt A .r:= zpt A .r + a; zpt A .i:« zpt A .i+ b;

END;

PROCEDURE subtract; {Subtracts current from previous stack pointee; pops stack; result in new pointee} BEGIN negate; add;

END;

PROCEDURE multiply; {Multiplies current and previous stack pointees; pops stack; result in new pointee} VAR a,b,c,d: REAL;

BEGIN

a: = zpt A .r; b:= zpt A .i; pop;

c:= (a # zpt A .r) - (b # zpt A .i); d:= (a # zpt A .i) + (b * zpt A .r); zpt A .r:= c; zpt A .i:=d;

END;

PROCEDURE divide; {Divides previous stack pointee by current; pops stack; result in new pointee}

BEGIN

invert;

multiply;

END;

PROCEDURE cexp; {Complex exponential function of current stack pointee}

VAR mag: REAL;

BEGIN

mag:= EXP(zpt A .r);

zpt*.r: * mag#COS(zpt A . i);

zpt A . i: = mag#SIN( zpt A . i);

END;

PROCEDURE sinh; {Complex hyperbolic sine of current stack pointee}

VARz: cmplx;

BEGIN

z[l] :■ zpt A .r; z[2] := zpt A .i; cexp;

keyin(z); negate; cexp; subtract; zpt A .r:» 0.5*zpt A .r; zpt A .i:«0.5#zpt A .i;

END;

34 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

PROCEDURE cosh; {Complex hyperbolic cosine of current stack pointee} VAR z: cmplx;

BEGIN

z[ 1] := zpt*.r; z[2] := zpt*. i; cexp;

keyin(z); negate; cexp; add;

zpt*.r:= 0.5#zpt*.r; zpt*.i:= 0.5*zpt*.i;

END;

BEGIN {Initialize stack pointer; define it as head; zero pointee}

NEW(zpt); zroot:= zpt;

zpt*.prev: = NIL; zpt*.next: = NIL; clear;

END.

LISTING.TXT Contributed by David Gedeon. Accompanies "Programming Insight: Complex Math in Pascal," July 1987, page 121.

LISTING 1 - available operations PROCEDURE negate;

{Negative of current stack pointee}

BEGIN

zpt*.r := -zpt*.r; zpt*.i := -zpt*.i;

END;

PROCEDURE conjugate;

{Complex conjugate of current stack pointee}

BEGIN

zpt* .i : = - zpt*.i;

END;

PROCEDURE invert;

{Inverse of current stack pointee}

VAR mag: REAL;

BEGIN

mag : = (zpt*.r # zpt*.r) + (zpt*.i* zpt*.i); zpt*.r:« zpt*.r/mag; zpt*.i := -zpt*.i/mag;

END;

PROCEDURE add;

{Adds current and previous stack pointees; pops stack; result in new pointee}

VAR a, b: REAL;

BEGIN

a : =zpt*.r; b := zpt*.i; pop;

zpt*.r := zpt*.r + a; zpt*.i :■ zpt*.i + b;

END;

PROCEDURE subtract;

{Subtracts current from previous stack pointee; pops stack; result in new pointee} BEGIN negate; add;

END;

PROCEDURE multiply;

{Multiplies current and previous stack pointees; pops stack; result in new pointee} VAR a, b, c, d: REAL;

BEGIN

a :«* zpt*.r; b := zpt*.i; pop;

c :■ (a * zpt* ,r) - (b # zpt*. i); d :■ (a # zpt*•1) + (b * zpt*.r);

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 35

July

zpt'.r := c; zpt A .i : = d;

END;

PROCEDURE divide;

{Divides previous stack pointee by current; pops stack; result in new pointee} BEGIN invert; multiply;

END;

PROCEDURE cexp;

{Complex exponential function of current stack pointee}

VAR mag: REAL;

BEGIN

mag := EXP(zpt'.r); zpt".r := mag#COS(zpt“.i); zpt'.i := magKSINCzpt'M);

END;

PROCEDURE sinh;

{Complex hyperbolic sine of current stack pointee}

VAR z: cmplx;

BEGIN

z[l] := zpt\r; z[2] := zpt\i; cexp;

keyin(z); negate; cexp; subtract; zpt*.r := 0.5*zpt'\r; zpt\i := 0.5*zpt A .i;

END;

PROCEDURE cosh;

{Complex hyperbolic cosine of current stack pointee}

VAR z: cmplx;

BEGIN

z[l] := zpt A .r; z[2] :=zpt*.i; cexp;

key in (z); negate; cexp; add;

zpt\r := 0.5*zpt*.r; zpt".i :* 0.5*zpt".i;

END;

36

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

August

QDRGNINT.CRV Contributed by William A. McWorter Jr.

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123.

4

2

8

TA

OR

2

5

1

TA

90R

2

2

1

TA

180R

2

7

3

TA

270R

2

0

3

TA

ONBR

2

0

4

TA

90NBR

2

5

6

TA

180NBR

2

2

6

TA

270NBR

2

7

4

1

1

6

13

75

QDEKNGCH.CRV Contributed by William A. McWorter Jr.

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123.

Table caption4 4 4

TA

4

OR

0

1

0

3

TA

4

90R

2

3

2

3

TA

2

180R

2

1

0

0

TA

2

270R

0

1

0

0

4

0

3

2

1

5

7

100

140

QHILBRT.CRV Contributed by William A. McWorter Jr.

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123.

4

4

10

TA

OR

4

1

0

3

4

TA

90R

4

0

1

2

5

TA

180R

4

0

1

2

6

TA

270R

4

1

0

3

7

TA

OR

4

6

7

4

0

TA

90R

4

7

6

5

1

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 37

August

TA

180R

4

7 6

5

2

TA

270R

4

6 7

4

3

TA

OR

4

1 0

3

9

TA

90R

4

6 7

4

8

1

8

10

\x

OO

o

190

QSRPNSK.CRV Contributed by William A. McWorter Jr.

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123.

4

9

8

TA

OR

9

0

1

0

3

6

3

0

1

0

TA

90R

9

1

2

1

0

7

0

1

2

1

TA

180R

9

2

3

2

1

4

1

2

3

2

TA

270R

9

3

0

3

2

5

2

3

0

3

TA

OBR

3

4

4

4

0

0

0

0

0

0

TA

90BR

3

5

5

5

0

0

0

0

0

0

TA

180BR

3

6

6

6

0

0

0

0

0

0

TA

270BR

3

7

7

7

0

0

0

0

0

0

Table caption1 0

Table caption5 4 50 100

QPENTGRE.CRV Contributed by William A. McWorter Jr.

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123.

5

6

5

TA

OR

6

0

4

1

2

1

0

TA

72R

6

1

0

2

3

2

1

TA

144R

6

2

1

3

4

3

2

TA

216R

6

3

2

4

0

4

3

TA

288R

6

4

3

0

1

0

4

1

0

4

5

500

150

QSNOFLK.CRV Contributed by William A. McWorter Jr.

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123

6

TA

4

OR

6

4

TA

0

60R

1

5

0

Table caption<12 0 1

38 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

TA

120R

4

2

3

1

2

TA

180R

4

3

4

2

3

TA

240R

4

4

5

3

4

TA

300R

4

5

0

4

5

1

0

2

5

50

150

QAROHEAD.CRV Contributed by William A. McWorter Jr.

Accompanies "Programming Project: Creating Fractals'’ by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123.

6

3

24

TA

OR

3

0

7

17

TA

60R

3

1

8

12

TA

120R

3

2

9

13

TA

180R

3

3

10

14

TA

240R

3

4

11

15

TA

300R

3

5

6

16

TA

OR

3

23

1

6

TA

60R

3

18

2

7

TA

120R

3

19

3

8

TA

180R

3

20

4

9

TA

24 OR

3

21

5

10

TA

300R

3

22

0

11

TA

OR

3

12

23

1

TA

60R

3

13

18

2

TA

120R

3

14

19

3

TA

180R

3

15

20

4

TA

240R

3

16

21

5

TA

300R

3

17

22

0

TA

OR

3

7

17

18

TA

60R

3

8

12

19

TA

120R

3

9

13

20

TA

180R

3

10

14

21

TA

240R

3

11

15

22

TA

300R

3

6

16

23

4

2

7

17

4

6

320

1

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 39

QBRKINT.CRV Contributed by William A. McWorter Jr.

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123

4

2

8

TA

ONBR

2

0

1

TA

90NBR

2

2

6

TA

180NBR

2

2

3

TA

270NBR

2

0

4

TA

OR

2

5

4

TA

90R

2

2

6

TA

180R

2

7

6

TA

270R

2

0

4

1

0

8

12

22i

QBRICK.CRV Contributed by William A. McWorter Jr.

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr.

and Jane Morrill Tazelaar, August 1987, page 123.

4

2

6

TA

OR

2

0

1

TA

90R

2

2

5

TA

180R

2

2

3

TA

270R

2

0

4

TA

OR

2

1

4

TA

180R

2

3

5

2

0

2

8

10

225

QLACE.CRV Contributed by William A. McWorter Jr.

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987. page 123

12

3

24

TA

60R

3

0

1

2

TA

120R

3

3

4

5

TA

30R

3

6

7

0

TA

300R

3

1

8

9

TA

OR

3

10

11

12

TA

330R

3

7

0

1

TA

300R

3

8

13

14

TA

OR

3

15

10

16

40

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

TA

180R

3

6

7

17

TA

150R

3

11

18

3

TA

120R

3

4

15

19

TA

180R

3

13

6

20

TA

90R

3

18

3

4

TA

24 OR

3

11

18

21

TA

150R

3

8

13

6

TA

60R

3

7

0

22

TA

90R

3

13

6

7

TA

270R

3

0

1

8

TA

240R

3

18

3

23

TA

330R

3

4

15

10

TA

270R

3

15

10

11

TA

210R

3

1

8

13

TA

30R

3

3

4

15

TA

210R

3

10

11

18

1

0

10

6

10

180

QDRGBDRY.CRV Contributed by William A. McWorter Jr.

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123.

4

2

12

TA

OR

2

0

5

TA

90R

2

6

9

TA

180R

2

7

2

TA

270R

2

11

4

TA

OR

1

8

0

TA

90R

1

6

0

TA

180R

1

10

0

TA

270R

1

4

0

TA

OR

2

0

1

TA

90R

2

10

9

TA

180R

2

3

2

TA

270R

2

11

8

4

0

5 6

3

13

200

continual

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 41

QMDLQUIN.CRV Contributed by William A. McWorter Jr.

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123.

4

5

8

TA

OR

5

4

0

3

6

3

TA

90R

5

5

1

0

7

0

TA

180R

5

6

2

1

4

1

TA

270R

5

7

3

2

5

2

TA

OR

5

7

2

7

4

0

TA

90R

5

4

3

4

5

1

TA

180R

5

5

0

5

6

2

TA

270R

5

6

1

6

7

3

1

0

5

5

300

190

QMOORE.CRV Contributed by William A. McWorter Jr.

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123.

4

9

8

TA

OR

9

0

1

2

6

2

3

7

6

5

TA

90R

9

1

2

3

7

3

0

4

7

6

TA

180R

9

2

3

0

4

0

1

5

4

7

TA

270R

9

3

0

1

5

1

2

6

5

4

TA

OR

9

1

2

3

7

6

2

6

5

4

TA

90R

9

.2

3

0

4

7

3

7

6

5

TA

180R

9

3

0

1

5

4

0

4

7

6

TA

270R

9

0

1

2

6

5

1

5

4

7

Table caption1 0

Table caption4 4 200 100

QSRPNSK2.CRV Contributed by William A. McWorter Jr.

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123.

8

2

8

TA

OR

2

0

1

TA

315R

2

2

0

TA

270R

2

3

4

TA

90R

2

2

5

TA

45R

2

6

2

TA

225R

2

0

3

42

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

TA

180R

2

6

7

TA

135R

2

3

6

1

4

5

11

580

QCHRSTRE.CRV Contributed by William A. McWorter Jr.

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123.

5

3

10

TA

OR

3

9

0

6

TA

72R

3

5

1

7

TA

144R

3

6

2

8

TA

216R

3

7

3

9

TA

288R

3

8

4

5

TA

OR

3

1

5

4

TA

72R

3

2

6

0

TA

144R

3

3

7

1

TA

216R

3

4

8

2

TA

288R

3

0

9

3

1

5

10

7

180

QDRGNCRD.CRV Contributed by William A. McWorter Jr.

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123.

4

2

8

TA

OR

2

0

5

TA

90R

2

2

5

TA

180R

2

2

7

TA

270R

2

0

7

TA

OBR

2

4

1

TA

90BR

2

6

1

TA

180BR

2

6

3

TA

270BR

2

4

3

1

0

6

11

400

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1987 43

QDRGN.CRV Contributed by William A. McWorter Jr.

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123.

4

2

4

TA

OR

2

0

1

TA

90R

2

2

1

TA

180R

2

2

3

TA

270R

2

0

3

1

0

8

11

400

QGOSPER.CRV Contributed by William A. McWorter Jr.

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123

6

7

12

TA

OR

7

0

7

9

2

0

0

11

TA

60R

7

1

8

10

3

1

1

6

TA

120R

7

2

9

11

4

2

2

7

TA

180R

7

3

10

6

5

3

3

8

TA

240R

7

4

11

7

0

4

4

9

TA

300R

7

5

6

8

1

5

5

10

TA

OR

7

5

6

6

8

3

1

6

TA

60R

7

0

7

7

9

4

2

7

TA

120R

7

1

8

8

10

5

3

8

TA

180R

7

2

9

9

11

0

4

9

TA

24 OR

7

3

10

10

6

1

5

10

TA

300R

7

4

11

11

7

2

0

11

3

0

4

2

10

3

220

120

SZPAK.LST The following five listings accompany "Logic Grammars" by Stan Szpakowicz, August 1987, page 185.

Listing 1:

statements —> statement, [»;'], statements.

statements —> [ ].

statement —> [skip].

statement—> [id(V)], [:«], expr.

statement—> [if], condition, [then], statements, [fi],

statement— > [while], condition, [do], statements, [od].

condition —> [not], relation, condition — > relation, relation —> expr, comp_op, expr. comp_op —> ['■']. comp_op —> [■<•].

44 BYTE 7 . LISTINGS SUPPLEMENT • JUI.Y-SF-PTHMBER, 1987

expression --> primary.

expression —> expression, arith_op, primary.

primary —> [id(V)]. primary —> [num(N) ].

arith_op — > [' + *]. arith_op —> ['-']• arith_op —> [•*•]. arith_op —> ['/*].

[end listing 1]

Listing 2:

1*1*1 statement^, N)

token(id(V), K, L), token(: = , L, M), expr(M, N).

1*2*1 expr(K, L) :-primary(K, L).

1*3*1 expr(K, N) :-expr(K, L), aritluop(L, M), primary(M, N).

/*4*/ primary(K, L) token(id(V), K, L).

1*5*1 primary(K, L) token(num(V), K, L).

1*6*1 arith_op(K, L) :-token(+, K, L).

1*7*1 token(T, [T|Ts], Ts).

[end listing 2]

Listing 3

program(s(Stmt, Stmts)) —>

statement(Stmt), [';']# statements(Stmts).

statements(s(Stmt, Stmts)) —> statement(Stmt), [';*], statements(Stmts). statements(skip) —> [].

% a sequence of statements is represented as a nested term,

% for example s(Stmtl, s(Stmt2, s(Stmt3, skip))),

% where Stmtl, Stmt2, Stmt3 represent individual statements

statement(skip) —> [skip]. statement(let(V, E)) —> [id(V)], [:=], expr(E). statement(if(C, Stmts)) —>

[if], condition(C), [then], statements(Stmts), [fi]. statement(while(C, Stmts)) —>

[while], condition(C), [do], statements(Stmts), [od].

condition(not(C)) —> [not], relation(C). condition(C) —> relation(C).

relation(cond(Op, El, E2)) —>expr(El), comp_op(Op), expr(E2).

comp_op(' =') —> [’*']. comp_op('<') —> [*<'].

[end listing 3]

Listing 4:

interm_code(s(Stmt, Stmts)) —>

interm_code(Stmt), interm_code(Stmts). interm_code(skip) —> []. interm_code(let(V, E)) -->

expr_internucode(E), [store(V)]. interm_code(if(C, Stmts)) —>

{ newlabel(L) }, cond_interm_code(not(C)),

[Jmp_cond(L)], interm_code(Stmts),

[label(L)].

interm_code(while(C, Stmts)) —>

{ newlabel(Ll) ), { newlabel(L2) },

[label(Ll)],

condLinterm_code(not(C)),

[Jmp_cond(L2)], interm_code(Stmts),

[Jmp(Ll)], [label(L2)].

[end listing4]

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 45

Listing 5:

The source program: x := a; y : = n; z := 1; while not i < 1 do if y/ 2#2< y then z := z # x; fi;

x := x # x; y : = y/2; od; H

The resulting object code:

load(a)

store(x)

load(n)

store(y)

loadc(l)store(z)

label($lbll)

loadc(l)

store($meml)

load(i)

sub($meml)

tst_neg

jmp_cond($lbl2)

etc.

[end listing 5]

SZPAK.BNL Contributed by Stan Szpakowicz.

Accompanies “Logic Grammars" by Stan Szpakowicz, August 1987, page 185. Written in Prolog using logic grammars.

%

* Note: In order to execute this program, a Prolog interpreter must support logic grammars or definite-clause grammars

% = = - main program === compile

set_gensym( "$lbl" ), set_gensym( "$mem" ), read_in( Chars ), lsym_list( LexSyms, Chars, [] ), program( Tree, LexSyms, [] ), interm_code( Tree, Code, [] ), write_out( Code ), !. compile :-write( ’Sorry' ), nl.

% read in a sequence of characters terminated by a tf read_in( Chars ) get( Ch ), read_in( Ch, Chars ).

read_in(35, []):-!. %H

read_in( Ch, [Ch | Chars] ) :-getO( Chi), read_ln( Chi, Chars ).

% print the generated code one instruction per line write_out( [ ] ). write_out( [Instr| Instrs] )

write( Instr ), nl, write_out( Instrs ).

% (skips initial white space) % lexical analysis % syntactic analysis % code generation

% **= scanner =«■*

% list of lexical symbols lsym_list( [LexSym | LexSyms] ) —>

lsym( LexSym ), !, opt_space, lsym_list( LexSyms ). lsym_list( [])—>[].

% one lexical symbol (input tokens are ASCII codes) lsym( IdOrKwd ) —> letter( L ), alphanums( Ls ),

{ name( Nm, [L | Ls] ) }, { wrap_name( Nm, IdOrKwd ) }. lsym( num( N ) ) —> digit( D ), digits( Ds ),

{ name( N, [D | Ds] ) }.

lsym( : = ) —> [58], [61]. % colon, equals

lsym( S ) —> [Ch], { name( S, [Ch] ) }.

46 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

% optional white space between lexical symbols opt_space—>white_space, !, opt_space. opt_space —> [ ].

% recognizing classes of ASCII codes letter( L ) — > [L], { is_letter( L ) }. digit( D ) —> [D], { is_digit( D ) }. white_space—> [Ch], { is_white_space( Ch ) }.

is_letter( Ch ) 65 =< Ch, Ch =< 90. is_letter( Ch ) 97 =< Ch, Ch =< 122.

is_digit( Ch ) 48 =< Ch, Ch =< 57.

is_white_space( 32 ). X blank space

is_white_space( 13 ). % new line (this would be 10 in Quintus Prolog)

is_white_space(9). X tab

t

% keywords and identifiers

alphanums( [L | Ls] ) —> letter( L ), alphanums( Ls ). alphanums( [L | Ls] ) —> digit( L ), alphanums( Ls ). alphanums( [ ] ) —> [].

wrap_name( Nm, Nm ) is_keyword( Nm ). wrap_name( Nm, id( Nm ) ).

% table of keywords

is_keyword( if ). is_keyword( then ). is_keyword( fi ).

isJceyword( while ). is_keyword( do ). is_keyword( od ).

is_keyword( skip ). is_keyword( not).

X integers

digits( [D I Ds] ) —> digit( D ), digits( Ds ). digits( [])-->[].

% === parser

program( s( Stmt, Stmts) ) —>

statement( Stmt ), [';'], statements( Stmts ).

statements( s( Stmt, Stmts) ) —>

statement Stmt), [•;'], !, statements ( Stmts ). statements( skip ) --> [ ].

X a sequence of statements is represented as a nested term,

X for example s( Stmtl, s( Stmt2, s( Stmt3# skip ) ) ),

X where Stmtl, Stmt2, Stmt3 represent individual statements

statement skip ) —> [skip].

statement^ let( V, E ) ) —> [id( V )], [:«], expr( E ). statement^ if( C, Stmts ) ) — >

[if], condition( C ), [then], statements( Stmts ), [fi]. statement while( C, Stmts ) ) —>

[while], condition( C ), [do], statements( Stmts ), [od],

condition( not( C ) ) —> [not], relation( C ). condition( C ) —> relation( C ).

re la t ion ( cond( Op, El, E2 ) ) —> expr( El), comp_op( Op ), expr( E2 ).

comp_op( •■' ) —> [*■*]. comp_op( '<* ) —> ['<’].

expr( E ) —> add_expr( AE ), rest_expr( AE, E ). rest_expr( AE1, E ) —>

['+'], add_expr( AE2 ), rest_expr( e( ' + AE1, AE2 ), E ). rest_expr( AE1, E ) —>

[*-'], add_expr( AE2 ), rest_expr( e( AE1, AE2 ), E ). rest_expr( E, E ) —> [ ].

add_expr( AE ) —> mult_expr( ME ), rest_add_expr( ME, AE ). rest_add_expr( ME1, AE ) —>

['»'], mult_expr( ME2 ), rest_add_expr( e( ' *', ME1, ME2 ), AE ).

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 47

rest_add_expr( ME1, AE ) —>

['/']> mult_expr( ME2 ), rest_add_expr( e( • /', ME1, ME2 ), AE ). rest_add_expr( E, E ) —> [ ].

mult_expr( var( V ) ) — > [id( V )]. mult_expr( num( N ) ) —> [num( N )]. mult_expr( E ) —> [•('], expr( E ), [')'].

% === code generation ===

% statements

interm_code( s( Stmt, Stmts ) ) —>

interm_code( Stmt), interm_code( Stmts ). interm_code( skip ) —> [ ]. interm_code( let( V, E ) ) —>

expr_interm_code(E), [store( V)]. interm_code( if( C, Stmts ) ) —>

{ newlabel(L ) }, cond_interm_code( not( C ) ),

[Jmp_cond( L)], interm_code( Stmts ),

[label( L)].

interm_code( while( C, Stmts ) ) —>

{ newlabel( LI) }, { newlabel( L2 ) },

[label( LI )],

cond_interm_code( not( C ) ),

[jmp_cond( L2 )], interm_code( Stmts ),

[Jmp(Ll)], [label( L2 )].

X conditions

cond_interm_code( not( not( C ) ) ) —> cond_internucode( C ). cond_interm_code( not( R ) ) —>

rel_interm_code(R), [flip].

X flip: negate the contents of the condition register cond_interm_code( R ) ~>

rel_interm_code( R).

X relations

rel_interm_code( cond( Op, El, E2 ) ) —>

expr_interm_code( E2 ), { newmemloc( M) }, [store( M)], expr_interm_code( El), [sub( M )], tst_interm_code( Op ).

% set the condition register tst_interm_code( ' =' ) —> [tst_zer]. tst_interm_code( '<* ) —> [tst_neg].

X expressions

expr_interm_code( e( Op, El, E2 ) ) —>

expr_lnterm_code( E2 ), { newmemloc( M) }, [store(M)], expr_internucode( El), eop_interm_code( Op, M ). cxpr_interm_code( var( V ) ) —>

[load( V)].

X load a constant expr_interm_code( num( N ) ) —>

[loadc(N)].

eop_interm_code( ' +», M) — > [add( M)]. eop_internucode( , M ) —> [sub( M )]. eop_interm_code( »*», H) — > [mul( M)]• eop_interm_code( */•, M) —> [div( M)].

% auxiliaries newlabel( L) :

gensym( "$lbl M , L ). newmemloc(M) :

gensym( M $mem", M ).

% === utilities = = =

% symbol generator (preset in the main program) set_gensym( Pref )

retract( sym( Pref, _) ), fail. set_gensym( Pref )

assert( sym( Pref, 1 ) ).

gensym( Pref, Sym )

retract( sym( Pref, Num ) ),

4 H BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1987

Numl is Num + 1,

assert( sym( Pref, Numl ) ),

glue( Pref, Num, Sym ).

glue( Pref, Num, Sym )

name( Num, Digits ), append( Pref, Digits, All ), name( Sym, All), !.

% well, you can' t have a program without append... append( [], Z, Z).

append( [A | X], Y, [A | Z] ) :-append( X, Y, Z ).

X end of program

DRAGON.BAS Contributed by William A. McWorter Jr.

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123.

Note 1

Note 2

Note 3

Note 4

Note 5

Note 6

Note 7

Note 8

Note 9

Note 10

Note 11

Note 12

Note 13

Note 14

Note 15

Note 16

Note 17

Note 18

Note 19

Note 20

Note 21

Note 22

Note 23

Note 24

Note 25

Note 26

Note 27

Note 28

Note 29

Note 30

Note 31

Note 32

Note 33

Note 34

Note 35

Note 36

Note 37

Note 38

Note 39

Note 40

Note 41

Note 42

278 GOSUB 310

279 NEXT I

280 PRINT"(1)NEW BIRTH CELL LIST, (2)NEW AGE, (3)SAVE TO DISK ": A$=INPUT$(l) :0N INSTR(»123", A$) GOTO 330,340,400 290 RUN

300 '-Dragon procedure

310 IF DAY=0 THEN CODE=I(CELL(DAY)) :G0SUB 450:RETURN

320 K(DAY)=1:WHILE K(DAY)<=G(CELL(DAY) ,0) :CELL(DAY-l)=G(CELL(DAY),K(DAY)) :DAY=DAY-1:GOSUB

310:DAY=DAY+1:K(DAY)=K(DAY)+1:WEND:RETURN

330 ERASE W, K, CELL: GOTO 230

340 ERASE K,CELL:GOTO 240

350 '-Load dragon routine

360OPEN"I",l,C$+".CRV":INPUT# 1,D,M,L:DIMG(M-1,L) ,I(M-1)

370 FOR 1=0 TOM-1: INPUT# 1,G(I,0) :FOR J=1 TO G(l,0): INPUT# 1,G(I, J) :NEXT J, I 380 FOR 1=0 TO M-l: INPUTS 1,1(1): NEXT I: CLOSE: RETURN

390 '-Save dragon routine

400 INPUT"CURVE NAME";C$:OPEN "0",1,C$+".CRV"

410 PRINT# l,D;M;L:FOR 1=0 TO M-l:PRINT# 1,G(1,0); :F0R J=1 TO G(I,0)

420 PRINT# 1,G(I, J); :NEXT J:NEXT I:FOR 1=0 TO M-l:PRINT# 1,1(1);:NEXT I 430 CLOSE:GOTO 280

440 '-Routine to interpret a cell

450 IF C0DE<0 THEN RETURN

460 IF C0DE<DTHEN X=X+X(C0DE):Y=Y-Y(C0DE):LINE-(X,Y),I MOD 7+l:RETURN 470 X=X+X(C0DE-D):Y=Y-Y(CODE-D):PRESET(X,Y):RETURN

QRULES.TXT Contributed by William A. McWorter Jr.

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123.

Running QDRAGON

The new QDRAGON.BAS is written in QuickBASIC to exploit the DRAW commands and to make data entry less tedious. As I understand it, only the SCREEN commands must be changed to suit the graphics adapter available. The LINE commands have been replaced by DRAW commands to permit drawing cells that are more exotic than simple line segments. The default is a line segment drawn in a direction determined by the cell label number. The length of the line segment is determined by scale factor held in the "cell length" variable. If something else is desired, you must type in the appropriate sequence of DRAW commands. Such a sequence will be sized by the value in the "cell length" variable. The program displays the DRAW commands it will use.

QDRAGON.BAS improves on the user interface but is not yet ideal. It pretends it knows what you want as data and displays what it will use if you don' t enter any data. Pressing Return repeatedly will show currently recorded data and how the program wants the data typed in. Pressing FI at any time will draw the dragon determined by current data. The program always has complete data to draw some dragon. To enter data for a new dragon, simply enter the data requested followed by Return. To back up and change or view previously requested data, end entry with a ].

The first thing the program wants to know is if you want a dragon stored on disk. Pressing Return or ] ignores this request and displays the next, or previous, thing it wants. Otherwise you type in the name of a dragon stored on disk followed by Return or ], or FI if you want the program to draw the dragon you have named. Dragons stored on disk contain #all# the data required by the program, including positioning on the screen and the birth cell list. Hence loading a dragon from disk can be followed immediately by FI which will draw it on the screen.

The next thing the program wants is the number of directions. This request is the number of cell orientations. Entering the number 4 means all cells are oriented in four directions, east, north, west, or south, as if reading a map. The program assumes that all cells are single line segments oriented in one of four directions unless told otherwise by you or the input file. In any case, the program will display the DRAW commands it will use. Entering the DRAW commands wanted (followed by Return, ], or FI) changes the default value. Pressing ] following data entry displays what the program thinks you typed.

Following the 'number of directions' request, QDRAGON.BAS wants the maximum cell division. This is so that the program can begin to dimension the genetic code array. You type in this value if it differs from the displayed value (Return cycles forward through data entry). The genetic code requires two dimensions, so if FI is pressed now, all entries in the genetic code array will be zero, producing a dull dragon. The program redimensions the genetic code array whenever one of its dimensions is changed.

Next, the program wants the total number of cell types. This number completes the dimension of the genetic code array. The program displays, as always, what it thinks should be the number of cell types. Typing Return accepts the program's choice and displays what the program wants next and the value it will use if you don't change it.

After typing Return, the program displays the DRAW commands it will execute for the first cell. You should type Return to go on to the next program request, or type in the DRAW commands you want for the first cell followed by Return to advance to the next request or ] to edit or preview the previous request. If you want a cell to be an invisible line segment, typing a dash will cause the program to record the appropriate DRAW commands, and if you want a 'do nothing' cell, typing * makes the program fill in DRAW commands that do the Job.

50 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

Ending the entry with Return, the program will now exhibit the label of the first child of the first cell. Each cell divides into a number of cells, numbered from one to the number of cells into which the cell divides. A user entry here should be a cell label, a number between 0 and one less than the total number of cells. Typing Return causes the program to ask for the next child of the current cell. If the cell has fewer children than the maximum, the last child cell should be followed by a period.

Whenever the program asks you for the last child of a cell labelled a multiple of the number of directions, it permits you to end entry vfith an # to abort this feature. Without the # entry, the program will fill in child cells cyclically up to the next cell labelled a multiple of the number of directions and display the draw code for the next cell, which is a multiple of the number of directions.

After all cells and their children have been displayed, the program requests the number of cells in the birth cell list. Dragons can begin life as a single cell (number of cells in birth cell list, 1) or as several cells, each drawn in a different color. Next the dragon’s age in days is requested. Following this comes a request for cell length and the position on the screen where drawing is to begin. The program draws the dragon starting at this position.

Finally, the program asks if the dragon just drawn is to be saved on disk. If so, you type a name of up to 8 letters followed by Return or ]. Only Control-Break or illegal data entry ends the program.

QDRAGON.BAS displays DRAW commands instead of numbers, so ignore interpreter values in the table. The relation between interpreter values in the table and the draw codes in the program is I->TA360I/DR. Invisible cells end in BR and 'do nothing' cells end in NBR.

Have a good time exploring fractals. I have.

-William A. McWorter Jr.

QDRAGON.BAS Contributed by William A. McWorter Jr.

Accompanies "Programming Project: Creating Fractals" by William A. McWorter Jr. and Jane Morrill Tazelaar, August 1987, page 123.

' This program is QDRAGON.BAS, a QuickBASIC program for drawing fractals.

' Inputs to this program are the files with a .CRV suffix. Rules for running it are in QRULES.TXT.

d=4:l=2:m=4:w=l:s=10:n=5:x=320:y=175

dim i$(m-l),g(m,l),w(w):a=360/d

prinf'The program tries to anticipate your wishes."

prinf'You can cycle through the data for previewing"

prinf'or editing, or enter entirely new data."

print"<cr> cycles forward through data entry"

print"<]> cycles backwards through data entry."

print"<Fl> at any time draws the dragon with current data."

prinf'But pressing it now will get you only an empty screen."

prinf'The backspace key allows erasing the last-typed character."

print

begin: print" input dragon? (<cr> or<]> if no) :t=pos(0)+l:gosub getcmd

ifi$>" "then open"I",01,1$+".crv"

input01,d,l,m:redim i$(m-l) ,g(m,l) :a=360/d

for i*0 to m-1: input^l, i$(i) :for J=0 to 1: input01,g(i,J) :next J,i

lnput#l,w:redim w(w) :for i=l to w: inputs,w(i) :next i

input#l,s,n,x,y:close

end if

11’ a$*"]" then gotocrvsave If a$=chr$(0) then goto program locate csrlin,pos(0) ,1

drctns: print''number of directions"; t=pos(0)+l: print d; :gosub getcmd If i$>" " then d=val( i$) :a=360/d If a$=chr$(0) then goto program 1 f a$=" ]" then goto begin

dvsn: prinf'max cell division";

t=pos(0)+l: print 1; :gosub getcmd

if i$>" " then l=val(i$):redim g(m-l,l), i$(m-l)

If a$=chr$(0) then goto program If a$="]" then goto drctns

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 51

cellno: print"number of cells";

t=pos(0)+l:print m; :gosub getcmd

if i$>" " then m=val(i$):redim g(ra-l,l), i$(m-l)

if a$=chr$(0) then goto program

if a$="]" then goto dvsn

i=0:J =1

gnetic.-if i$(i)=" " then i$(i)="TA"+str$((i mod d)*a)+"R"

if g(i,0)=0 then g(i,0)=l

drawcode: prinf'draw code for cell"i"is";

t=pos(0)+l:print" "i$(i)"<*> = 'donothing'; <-> = 'invisible' gosub getcmd if i$>" "then

if instr( i$, "#") then i$(i)="TA"+str$((i mod d)#a)+"NBR":goto drawcodel if instr(i$,then i$(i)="TA"+str$( (i mod d)*a)+"BR":goto drawcodel i$(i)=i$ end if

drawcodel: if a$=chr$(0) then goto program if a$="]" then

i«i-l:if i<0 then goto cellno else j=g(i,0) :goto loop end if

J-l

loop: print" cell"i'"s number"J "child is"; t=pos(0)+l:print g(i,j); if J=g(i,0) then

if (i mod d)=0 then print" (end this entry with (#) to abort skip)"; end if

gosub getcmd if i$>" "then

g(i,J)-val(i$): if instr(i$,".") then g(i,0)«J end if

if a$=chr$(0) then goto program

if a$="]" then

if J =1 then goto gnetic

J=J-l:goto loop

end if

J=J+1: if j<=g(i,0) then goto loop if (i mod d)<>0 then i*i+l:goto ilupend if i+d<=ra then

if i$=" " then i=i+l:goto ilupend if instr(i$,"»") then i=i+l:goto ilupend for u=i+l to i+d-1 if i$(i) =" " then i$(u) = " ":goto 10

if instr( i$( i), "B") then i$(u) ="TA"+str$( (u mod d)«a)+"BR":goto 10 i$(u)="TA"+str$((u mod d)#a)+"R"

10 g(u,0)=g(i,0) :for v=l tog(i,0) g(u,v)=g(i,v)-(g(i,v) mod d)+((g(i,v)+u) mod d) next v,u: i*i+d:goto ilupend end if i=i+l

ilupend: if i<m then J =1: goto gnetic

initword:print"birth cell list length";

t=pos(0)+l:print w; :gosub getcmd

if i$>" " then w=val(i$):redim w(w) :goto bcells

if a$=chr$(0) then goto program

if a$="]" then i=m-l: J=g(i,0) :goto loop

bcells: i«l:print"cells" loopl: print i"-th cell:"; t=pos(0)+l:print w(i); :gosub getcmd ifl$>" " then w(i)=val(i$) if a$=chr$(0) then goto program

if a$="]" then if i=l then goto initword else i=i-l:goto loopl i=i*H:if i<«w then goto loopl

order:print"number of day's growth"; :t=pos(0)+l:print n;:gosub getcmd if i$>" " then n*val(i$) if a$=chr$(0) then goto program if a$="]" then i»w: goto bcells

52 BYTE LISTINGS SUPPLKMKNT • JULY-SEPTEMBER, 1987

length: print" cell length"; t=pos( 0 )+l:print s; :gosub getcmd if i$>" " then s=val( i$) lfa$=chr$( 0 ) then goto program if a$="]" then goto order

xpos:print"x-origin"; t=pos( 0 )+l: print x; :gosub getcmd

ifi$>" " thenx=val(i$) if a$=chr$( 0 ) then goto program if a$="]" then goto length

ypos:print"y-origin"; t=pos( 0 )+l:print y; :gosub getcmd ifi$>" " theny=val(i$) if a$="]" then goto xpos if a$=chr$( 0 ) then goto program

crvsave: print"save name? (<cr> or<]> if no) ";: t=pos( 0 )+l:gosub getcmd

if i$="]" then goto ypos

ifi$>" "then

open" 0 ", 1 ,i$+".crv"

print#l,d;l;m

for i=0 to m-l:print#l,i$(i) :for J=0 to l:print#l,g(i,j); next J:print#l,:next i

print#l,w; :for i=l to w:print#l,v(i); :next i:print#l, print#l,s;n;x;y:close end if

if a$="]" then goto ypos if a$=chr$( 0 ) then goto program goto begin

program:screen 2 :els:dim k(n),cell(n) draw"BM="+varptr$(x)+",="+varptr$(y)

for i=2 to w+l:cell(n)=w(i-l) :draw"C="+varptr$(i) :gosub dragon:next i erase k,cell:goto crvsave

dragon:

if n =0 then draw i$(cell(n))-»-str$(s):return

k(n)=l:vhile k(n)<=g(cell(n) , 0 ) :cell(n-l)=g(cell(n) ,k(n)) :n=n-l

gosub dragon:n=n+l:k(n)=k(n)+l:wend

return

getcmd:i$=" ":t 0 =pos( 0 )-l:locate csrlin,t,l getcmdl: a$=" ":a$=input$(l)

if instr(chr$( 13 )+"]"+chr$( 0 ),a$) then print:return if a$=chr$( 8 ) then 1 f pos ( 0 ) = t then goto getcmdl

i$=left$(i$,len(i$)-l): locate csrlin,pos( 0 )- 1 , 1 :goto getcmdl end if

I$=I$+a$:print a$;

if len(i$)=l then print string$( t 0 -t+ 2 , 32 );: locate csrlin, t+ 1,1 goto getcmdl

INDEX.PAS Contributed by Dick Pountain. Accompanies "Focus on Algorithms: Search and Destroy," August 1987, page 257.

{ INDEX.PAS in Turbo Pascal 3.0 for IBM PC and compatibles }

{ A book indexing program — requires an input file — execute as .COM )

{ Also requires a Boring Words dictionary, BORING.DIC, in the .COM file's directory }

{ To execute .COM file, enter "index <inputfilename><outputfilename> } program INDEX;

const CR = #13; { carriage return character )

const maxDict = 3750; {maximum allowable dictionary entries}

type letters = ' a 1 .. 1 z •; word type* string[l6]; nodeptr * "nodetype; node type* record

info: word type;

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 53

next: nodeptr end;

var inputFile,outputFile: text;

inputFilename, outputFilename: string[127];

chr,flrstletter: char;

sortList: array [letters] of nodeptr;

i: letters;

word: wordtype;

boringWords: array [1. .maxDict] of wordtype; dictionary : text; endDict : integer; procedure InitFiles;

begin { open input and output files }

inputFilename := paramSTR(l);

Assign(inputFile,inputFilename);

Reset(inputFile); outputFilename :* paramSTR(2);

Assign(outputFile, outputFilename);

Rewrite(outputFile); end;

procedure GetWord(VAR infile: text; VAR word: wordtype); begin { read a cleaned-up word from the input file }

word : = ' *; repeat

read(infile,chr);

if chr in [ 1 A f • • * Z' ]

then chr : = char(ord(chr)+32);

if chr in ['a'..'z']

then word : = word+chr;

until (chr = * ') or (chr = CR) or eof (inf ile) end;

procedure Place (VAR list: nodeptr; word: wordtype); var p,q,newnode: nodeptr;

{ the array of 26 lists }

{ initialize to blank }

{ convert all to lowercase }

{ only accept alpha characters } { add to word being built}

found: boolean; begin q := nil; p := list; found :* false; while (p<> nil) and (not found) and (word >= p". info) do if p*. info = word then found : * true else begin q := p; p : = p*.next end; {while} if not found then begin New(newnode); newnode*.info :» word; if q = nll then begin

newnode*.next :■ list; list :* newnode end

else begin

newnode*.next :=q*.next; q*.next : = newnode end end end;

{ insert new word into list in sorted position only if unique }

{ p points to head of list }

{ not end of list and } { word not already here and } { word alphabetically later than current} £ does this node contain our word? } { yes! word is already here }

{ remember this node and } { move on to the next one }

{ word isn * t already here }

{ create a new node } { put word in its info field } { list was empty }

{ newnode becomes first}

{ insert after node q }

procedureSquirtOut(list: nodeptr; VARoutfile: text); begin { send sorted list to output file }

while list <> nil begin

writeln(outfile,list*.info); list :«list*.next end end;

procedure ReadDictionary;

var i: Integer;

begin

Assign(dictionary,'BORING.DIC 1 );

Reset(dictionary); i :■ 1;

repeat

54 BYTE LISTINGS SUPPLEM ENT • JULY-SEPTEMBER. 1987

readln(dictionary,boringWords[i]); i := i + 1

until eof(dictionary) or (i > maxDict);

endDict : * i; {number of actual dictionary entries}

Close(dictionary) end;

function Boring(word: wordtype): boolean; var left,right,try,svleft,svright: integer; begin left s-1; right :* endDict; repeat

svleft := left; svright := right; try := (left + right) div 2 ; if word < boringWords[try] then right : = try - 1 else left :=try + l;

until (word = boringWords[try]) or (svleft > svright) ; if word = boringWords[try] then Boring : = true else Boring := false end;

begin { main program }

InitFiles;

ReadDictionary;

fori := 'a' to 'z' do sortList[i] :=nil; { initialize all the lists }

while not eof (inputFile) do

begin

GetWord(inputFile,word);

firstletter : * word[l]; { get first letter }

if not Boring(word)

then Place(sortList[f irstletter] ,word); { put word in proper place }

end; {while}

fori :» ’a' to *z' doSquirtOut(sortList[i],outputFile); writeln('Keywords are contained in ',outputFilename);

Close(inputFile);

Close(outputFile) end.

OPS8085.ARI Contributed by Alex Lane. Accompanies the article "Simulating a Microprocessor," August 1987, page 161.

% Subject: 0PS8085.ARI - from Alex Lane: "Simulating a Microprocessor"

comp_regs(Regname)

retract(state(R,PC,SP,_)), reg(Regname,Place), arg(Place,R,Reg),

X is A - Reg,

adJust_flags(A,X,_,Flags), asserta(state(R,PC,SP,Flags)).

acc_jnath_with_carry(Op,Regname)

retract(state(R,PC,SP,flags(_,_,_,CY,_))), % get what we need

% extract A from R % Place is location of Regname in R % extract register value % set up additions/subtractions

arg(l,R,A), reg(Regname,Place), arg(Place,R,Reg),

T1. [Op,Reg,CY],

T2 ■.. [Op,A,Tl],

X is T2, % evaluate

adJust_flags(A,X,Y,Flags), % adjust for flags

argrep(R,l,Y,NewR), % replace register value in R asserta(state(NewR,PC,SP,Flags)).

acc math(Op,Regname)

retract(state(R,PC,SP,_)), arg(l,R,A),

reg(Regname,Place), arg(Place,R,Reg), Tl-.. [Op,A,Reg],

X is Tl,

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 55

adjust_flags(A,X,Y,Flags), argrep(R,l,Y,NewR), asserta(state(NewR,PC,SP,Flags)).

reg_math(Op,Regname)

retract(state(R,PC,SP,flags(_,_,_,CY,_))), arg(l,R,A), reg(Regname,Place), % Place is location of Regname in R

arg(Place,R,Reg), % extract register value

T1 = .. [Op,Reg,TemReg],* take advantage of Arity inc() and dec() call(Tl),

adj ust_flags(A,TemReg,NewReg,flagsl(Z,S,P,_,AC)), argrep(R,l,NewReg,NewR), % replace register value in R

asserta(state(NewR,PC,SP,flags(Z,S,P,CY,AC))).

not_implemented. % some things are not worth doing.

undefined.

move (mem, mem).

move(mem,D)

retract(state(R,PS,SP,F)), arg(6,R,H), arg(7,R,L), get_mem(H,L,Data), argrep(R,D,Data,NewR), asserta(state(NewR,PC,SP,F)).

move(S,mem)

state(R,PS,SP,F), arg(6,R,H), arg(7,R,L), arg(S,R,Data), put_mem(H,L,Data).

move( S,D)

retract(state(R,P,SP,F)), arg(S,R,Sl), argrep(R,D,Sl,NewR), asserta(state(NewR,P,SP,F)).

reg_ptr(6,mem).

reg_ptr(A>B) B is (A + 2) mod 8. op(0). /*NOP*/

op(l) /* LXI BC */

retract(state(regs(A,_,_,D,E,H,L),PC,SP,Flags)),

get_mem(PC,C), Hi is PC + 1, get_jnem(Hi,B),

NewPC is PC-f 2,

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)).

op(2) /*STAXB*/

state(regs(A,B,C, put_mem(B,C,A).

op(3) /* INX B */

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)),

BC is 256* B + C + l, decompose(BC,NewB,NewC),

asserta(state(regs(A,NewB,NewC,D,E,H,L),PC,SP,Flags)).

op(4) reg_math(inc,b),!. /#INRB*/

op(5) reg_math(dec,b),!. /* DCR B */

op(6) /* MVIB, data*/

retract(state(regs(A,_,C,D,E,H,L),PC,SP,Flags)), get_mem(PC,B),

NewPC is PC + 1,

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)).

56 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

op(7)

op(9)

op(10) :

op(ll) :

op(12) :

op(13) :

op(l4) :

op(15) :

op(17)

op(18)

op(19)

op(20)

op(21)

op(22)

/ * RLC * /

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(Z,S,P,_,AC))),

CY is A mod 128,

A1 is (2 # A + CY) mod 256,

asserta(state(regs(Al,B,C,D,E,H,L),PC,SP,flags(Z,S,P,CY,AC))).

/# DAD B (CY only)#/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(Z,S,P,_,AC))),

NewL is L + C,

Carry is NewL/ / 256,

NewH is H + B + Carry,

CY is NewH// 256,

FL is NewL/\ 255,

FH is NewH / \ 255,

asserta(state(regs(A,B,C,D,E,FH,FL),PC,SP,flags(Z,S,P,CY,AC))).

/ # LDAX B # /

retract(state(regs(_,B,C,D,E,H,L),PC,SP,Flags)), get_mem(B,C,A),

asserta(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)).

/# DCX B #/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)),

BC is 256 # B + C - 1, decompose(BC,B1,Cl),

asserta(state(regs(A,Bl,Cl,D,E,H,L),PC,SP,Flags)).

reg_math(inc,c),!. /#INRC#/

reg_math(dec,c),!. /#DCRC#/

/#MVIC, data#/

retract(state(regs(A,B,_,D,E,H,L),PC,SP,Flags)), get_mem(PC,C),

NewPC is PC + 1,

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)).

/ # RRC # /

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(Z,S,P,_,AC))),

CY is A mod 2,

II is CY# 128,

Al is A//2+ 11,

asserta(state(regs(Al,B,C,D,E,H,L),PC,SP,flags(Z,S,P,CY,AC))). /# LXI DE #/

retract(state(regs(A,B,C,_,_,H,L),PC,SP,Flags)), memory(PC,E),

Hi is PC + 1, memory(Hi,D),

NewPC is PC+ 2,

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)).

I # STAX D #/

state(regs(A,_,_,D,E,_,_),_,_,_), put_mem(D,E,A).

/# INX D #/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)),

DE is 256 # D + E + 1,

D1 isDE H 256,

El is DE mod 256,

asserta(state(regs(A,B,C,D1,El,H,L),PC,SP,Flags)).

reg_math( inc,d), I. /#INRD«/

reg_math(dec,d), l. /#DCRD#/

/#MVID, data#/

retract(state(regs(A,B,C,_,E,H,L),PC,SP,Flags)), memory(PC,D),

NewPC is PC +1,

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)).

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 57

op(23) /* RAL */

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(Z,S,P,CY,AC))),

A1 is (2 * A + CY) mod 256,

NewCY is A mod 128,

asserta(state(regs(Al,B,C,D,E,H,L),PC,SP,flags(Z,S,P,NewCY,AC))).

op(25) /*DADD*/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(Z,S,P,_,AC))),

NewL is L + E,

Carry is NewL // 256,

NewH is H + D + Carry,

CY is NewH// 256,

FL is NewL / \ 255,

FH is NewH / \ 255,

asserta(state(regs(A,B,C,D,E,FH,FL),PC,SP,flags(Z,S,P,CY,AC))).

op(26) /* LDAXD */

retract(state(regs(_,B,C,D,E,H,L),PC,SP,Flags)), get_mem(D,E,A),

asserta(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)).

op(27) /* DCX D*/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)),

DEis 256#D + E-1, decompose(DE,D1,El),

asserta(state(regs(A,B,C,Dl,E1,H,L),PC,SP,Flags)).

op(28) reg_math(inc,e),!. /* INR E »/

op(29) reg_jnath(dec,e),!. /#DCRE#/

op(30) /# MVI E, data */

retract(state(regs(A,B,C,D,_,H,L),PC,SP,Flags)), get_mem(PC,E),

NewPC is PC + 1,

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)).

op(31) /*RAR»/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(Z,S,P,CY,AC))),

A1 is (A//2) + (128 *CY),

NewCY is A mod 2,

asserta(state(regs(Al,B,C,D,E,H,L),PC,SP,flags(Z,S,P,NewCY,AC))).

op(32) /# RIM (read interrupt mask) #/

not_implemented.

op(33) /# LXI HL #/

retract(state(regs(A,B,C,D,E,_,_),PC,SP,Flags)), get_mem(PC,L),

Hi is PC + 1, get_mem(Hi,H),

NewPC is PC + 2,

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)).

op(34) I* SHLD (store H L direct) #/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)), get_mem(PC,Lo), NextPC is PC 1,

get_mem(NextPC,Hi),

put_mem(Hi,Lo,L), NextLo is Lo + 1,

put_mem(Hi,NextLo,H),

NewPC is PC+ 2,

asserts(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)).

op(35) /# INX H #/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)),

HL is 256 * H + L + 1, decompose(HL,Hl,Ll),

asserta(state(regs(A,B,C,D,E,Hl,Ll),PC,SP,Flags)). op(36) reg_math(inc,h),!. /#INRH*/

op(37) reg_math(dec,h),!. /*DCRH*/

58 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

op(38) /* MVI H, data*/

retract(state(regs(A,B,C,D,E,_,L),PC,SP,Flags)), get_mem(PC,H),

NewPC is PC +1,

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)).

op(39) /*DAA*/

state(regs(A,B,C,D,E,H,L)flags(Z,S,P,CY,AC)), LSB is A/\ 15,

LSB > 9;

AC is 1, !, retract(state(_,PC,SP,F)),

NewA is A + 6,

asserta(state(regs(NewA,B,C,D,E,H,L),PC,SP,F)),

MSB is NewA / \ 240,

MSB >9;

CY is 1, !, retract(_,PC,_,_),

FinalA is NewA + 6,

asserta(state(regs(FinalA,B,C,D,E,H,L),PC,SP,F)).

op(4l) /# DAD H */

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(Z,S,P,_,AC))), NewL is L + L, % sum L plus lo-order register

Carry is NewL / / 256, % Carry is one if NewL > 255

NewH is H + H + Carry, % sum H with hi-order register

CY is NewH // 256, % CY flag is one if NewH > 255

FL is NewL /\ 255, t bring into byte range

FH is NewH / \ 255, % this one too

asserta(state(regs(A,B,C,D,E,FH,FL),PC,SP,flags(Z,S,P,CY,AC))).

op(42) /# LHLD (load HL direct) */

retract(state(regs(A,B,C,D,E,_,_),PC,SP,Flags)), get_mem(PC,Lo), NextPC is PC + 1,

get_mem(NextPC,Hi),

get_mem(Hi,Lo,L), NextLo is Lo+1,

get_mem(Hi,NextLo,H),

NewPC is PC+ 2,

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)).

op(43) /* DCX H */

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)),

HL is 256 * H + L - 1, decompose(HL,Hl,Ll),

asserta(state(regs(A,B,C,D,E,Hl,Ll),PC,SP,Flags)).

op(44) reg_math(inc,l),I. /* INR L#/

op(45) reg_math(dec,l),!. /* DCR L */

op(46) /* MVI L, data*/

retract(state(regs(A,B,C,D,E,H,_),PC,SP,Flags)), get_mem(PC,L),

NewPC is PC -f 1,

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)).

op(47) /* CMA (complement accumulator) */

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)), bit_xor(A,255,NewA),

asserta(state(regs(NewA,B,C,D,E,H,L),PC,SP,Flags)).

op(48) /* SIM (set interrupt mask) */

not_implemented.

op(49) /* LXI SP */

retract(state(Regs,PC,_,Flags)), get_mem(PC,SPL),

Hi is PC + 1, get_mem(Hi,SPH),

SP is 256 * SPH + SPL,

NewPC is PC+ 2,

asserta(state(Regs,NewPC,SP,Flags)).

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 59

op(50)

/* STA Adr (store accumulator in address) */ retract(state(regs(A, B, C, D, E, H, L), PC,SP,Flags)),

get_mem(PC,Lo), get_mem(HiAdr, Hi), put_mem(Hi,Lo,A), NewPC is PC+ 2,

HiAdr is PC + 1,

asserts(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)).

op(51)

/* INXSP */

retract(state(Regs,PC,SP,Flags)),

NewSP isSP + 1,

check_overflow(NewSP,FinalSP), asserts(state(Regs,PC,FinalSP,Flags)).

op(52)

/* INR M #/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(_,_,_,CY,_))), get_mem(H,L,Data),

NewData is Data + 1,

adj ust_flags(A,NewData,FinalData,flagsl(Z,S,P,_,AC)), put_mem(H,L,FinalData),

asserta(state(regs(A,B,C,D,E,H,L),PC,SP,flags(Z,S,P,CY,AC))).

op(53) /# DCR M #/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(_,_,_,CY,_))), get_mem(H,L,Data),

NewData is Data - 1,

adj ust_flags(A,NewData,FinalData,flagsl(Z,S,P,_,AC)), put_mem(H,L,FinalData),

asserta(state(regs(A,B,C,D,E,H,L),PC,SP,flags(Z,S,P,CY,AC))).

op(54) /# MVI M, data*/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)), get_mem(PC,Data), put_mem(H,L,Data),

NewPC is PC + 1,

asserts(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)).

op(55) /* STC (set carry) */

retract(state(Regs,PC,SP,flags(Z,S,P,_,AC))), asserts(state(Regs,PC,SP,flags(Z,S,P,1,AC))).

op(57) I* DAD SP */

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(Z,S,P,_,AC))), decompose(SP,SPH,SPL),

NewL isL + SPL,

Carry is NewL//256,

NewH is H + SPH + Carry,

CY is NewH//256,

FL is NewL/\ 255,

FH is NewH / \ 255,

asserta(state(regs(A,B,C,D,E,FH,FL),PC,SP,flags(Z,S,P,CY,AC))).

op(58) I* LDA Adr #/

re tract (state (regs (_, B, C, D, E, H, L), PC, SP, Flags)), get_mem(PC,Lo),

NextPC is PC + 1, get_mem(NextPC,Hi), get_mem(Hi,Lo,A),

NewPC is PC+ 2,

asserta(s tate(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)).

op(59) /*DCXSP*/

retract(state(Registers,PC,SP,Flags)),

NewSP is SP - 1,

check_overflow(NewSP,FinalSP),

asserta(state(Registers,PC,FinalSP,Flags)).

op(60) reg_jnath(inc,a), 1. /# INR A #/

op(6l) reg_math(dec,a),!. /*DCRA#/

op(62) /* MVI A, Data */

retract(state(regs(_,B,C,D,E,H,L),PC,SP,Flags)), get_mem(PC,A),

NewPC is PC + 1,

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)).

60

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

Chapter Notes

1 '_DRAGON PROGRAM_

2 '

3 'This is the DRAGON.BAS program in Microsoft BASIC for the IBM PC and compatibles. If you have QuickBASIC, QDRAGON.BAS is

4 'easier to use and comes with quite a few dragon files (.CRV) that will make your fractal wanderings considerably easier.

5 ' If you do not have that package, this program is fun and allows you to explore the dragons. It is not, however,

6 ' forgiving of mistakes. Any data-entry mistakes require that you start over. Have a good time!

7 •

8 '

9 1 2 3 4 5 6 7 8 9 11 '

12 'To avoid local variables, I have replaced the loop index K with a one-dimensional array K, which holds the loop index

13 'at each level of recursion, and exchanged the variable CELL for a one-dimensional array CELL, which holds the cell

14 'value at each level of recursion. Since Microsoft BASIC does not permit subscripted variables to be FOR.. .NEXT loop

15 ' indexes, I have replaced this loop with a WHILE.. .WEND block.

16 •

17 '

18 '

20 •-Initialize

30 DATA 14,12,11,13,10,9,15 40 CLEAR,,10000

42 CLS

. RM63/46 FOR 1=1 TO 7

48 READ X

49 NEXT I

50 '-Get dragon

60 INPUT; "DRAGON FROM DISK (<CR> if no) ",C$: IF C$>"" THEN G0SUB 360:PRINT:GOTO 210

70 INPUT"NUMBER OF DIRECTIONS" ;D: INPUT"NUMBER OF CELLS (equal or greater the number of directions) ";M: IF M<D THEN 70 80 INPUT"MAX NUMBER OF CELLS IN A CELL DIVISION"; L:PRINT"Follow each input cell with <CR>" :DIM G(M-1,L)

90PRINT"cyclic? (<CR> if no)»:IF INPUT$(l)=CHR$(13) THEN 140

100 J=0:WHILE J<M:PRINT"division of cell"J"(enter '.' after last cell of division less than"L:G(J,0)=L 110 FOR 1=1 TO L:INPUT;" ",A$:G(J,I)«VAL(A$):IF INSTR(A$,".") THEN G(J,0) = I: I=L

120 NEXT I :PRINT:FOR 1*1 TO G(J,0) :S=G(J,1) :T=S-(S MOD D):FOR K=J+1 TO J+D-1:G(K,0)=G(J,0) :G(K,I)=((S+K) MOD D)+T:NEXT K, I 130 J-J+D: WEND: GOTO 170

140 FOR J=0 TO M-1:PRINT"DIVISION OF CELL"J"(enter (.) after last cell of divisions less than"L:G(J,0)=L 150 FOR 1=1 TO L:INPUT;" ",A$:G(J,I)=VAL(A$) :IF INSTR(A$,".") THEN G(J,0) = I:I=L 160 NEXT I: PRINT:NEXT J

170 DIM I(M-l) :PRINT"If cell directions are CELL modulo NUMBER OF DIRECTIONS, then press <CR>": IF INPUT$(l) =CHR$(13) THEN FOR 1=0 TO M-l: I (I) = I MOD D: NEXT I: GOTO 210

180 FOR I=0 TO M-l:PRINT"DIRECTION FOR CELL"I;:INPUT I$:IF 1$="." THEN I(I)=-1 ELSE I(I)=VAL(I$)

190 NEXT I

200 f -Compute direction vectors

210 T=6.28318531^/D:DIM X(D-l),XX(D-1),Y(D-l),YY(D-l): FOR 1=0 TO D-1:XX(I)=C0S(I#T): YY(I)*SIN( I#T) :NEXT I 220 '-Get drawing parameters

230 INPUT"NUMBER OF BIRTH CELLS IN START PATTERN ";T:PRINT»Follow each birth cell input with <CR>" :DIM W(T-l): FOR 1=0 TO T-l: INPUT;" ", W(I) :NEXT I:PRINT

240 INPUT; "AGE IN DAYS ", DAY: INPUT;" CELL LENGTH »,W:F0R 1=0 TO D-1:X(I)=W#XX(I) :Y(I)=W*YY(I): NEXT I: PRINT 250 INPUT;" COORDINATES OF HEAD CELL (", X: INPUT;",", Y: PRINT")": DIM K(DAY),CELL(DAY)

260 *-Draw dragon and repeat

270 CLS

271 SCREEN 2 273 PRESET(X,Y)

275 FOR 1=0 TO T-l 277 CELL(DAY)=W(I)

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 49

August

op(63) /# CMC (complement carry) */

retract(state(Regs,PC,SP,flags(Z,S,P,CY,AC))), bit_xor(l,CY,NewCY),

asserta(state(Regs,PC,SP,flags(Z,S,P,NewCY,AC))).

op (Code) /# MOV Destination, Source #/

Code > 63, Code < 128,

B210 Is Code / \ 7, % decode which reg is in bits 0-2

B543 is (Code / \ 56) » 3, % do same for bits 3-5

reg_ptr(B210,S), reg_ptr(B543,D), move(S,D).

op(128)

acc_math(+,b),!

op(129)

acc_math(+,c),!

op(130)

acc_math(+,d),!

op(131) s

acc_jnath(+,e),!

op(132)

acc_math(+,h),!

op(133)

acc_math(+,l),!

op(134)

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), get_mem(H,L,Q),

X is A + Q,

adJust_flags(A,X,Y,Flags),

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,Flags)).

op(135) s

acc_math(+,a),!.

op(136)

acc_math_with_carry(+,b),!

op(13?)

acc_math_with_carry(+,c),!

op(138)

acc_math_with_carry(+,d),I

op(139)

acc_math_with_carry(+,e),!

op(l40)

acc_math_with_carry(+,h),l

op(l4l)

acc_math_with_carry(+,l),!

op(l42)

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), get_mem(H,L,Q),

X is A + Q,

adJust_flags(A,X,Y,Flags),

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,Flags)).

op(l43)

acc_math_with_carry(+,a),!

op(l4<)

acc_math(-,b),!.

op(l45)

acc_math(-,c),!.

op(l46)

acc_math(-,d),!.

op(147) !

acc_math(-,e),!.

op(l48)

acc_math(-,h),!.

op(l49)

acc_math(-,l),!.

op(150)

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), get_mem(H,L,Q),

X is A + Q,

adj ust_flags(A,X,Y,Flags),

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,Flags)).

% add B with carry

op(l51) acc_math(-,a),!.

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 61

August

op(152)

acc_math_with_carry(-,b),!

op(153)

acc_jnath_with_carry(-,c),!

op(1^4)

acc_math_with_carry(-,d),!

op(l55)

acc_math_with_carry(-,e),!

op(156)

acc_math_with_carry(-,h),!

op(157)

acc_math_with_carry(-,l),!

op(158)

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(_,_,_,CY,_))), get_mem(H,L,Q),

X is A-Q-CY,

adjust_flags(A,X,Y,Flags),

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,Flags)).

op(159)

acc_math_with_carry(-,a),!

op(l60)

acc_math(/\,b),!.

op(l6l)

acc_raath(/\,c),I.

op(162)

acc_math(/\,d),!.

op(163)

acc_math(/\,e),!.

op(l64)

acc_math(/\,h),!.

op(165)

acc_math(/\,1 ),!.

op(l66)

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), get_mem(H,L,M),

X is A / \ M,

adjust_flags(A,X,Y,flags(Z,S,P,_,_)),

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,l))).

op(167) % AND A (affects flags)

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), adJust_flags(A,A,Y,flags(Z,S,P,_,_)),

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,l))).

op(l 68 )

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), bit_xor(A,B,X),

adJust_flags(A,X,Y,flags(Z,S,P,_,_)),

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,0))).

op(169)

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), bit_xor(A,C,X),

adjust_flags(A,X,Y,flags(Z,S,P,_,_)),

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,0))).

op(170)

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), bit_xor(A,D,X),

adjust_flags(A,X,Y,flags(Z,S,P,_,_)),

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,0))).

op(171)

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), bit_xor(A,E,X),

adjust_flags(A,X,Y,flags(Z,S,P,_,_)),

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,0))).

op(172)

retract(state(regs(A,B,C,D,E,H,L),PC,SP,__)), bit_xor(A,H,X),

adjust_flags(A,X,Y,flags(Z,S,P,_,_)),

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,0))).

62 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

op(173)

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), bit_xor(A,L,X),

adJust_flags(A l X,Y,flags(Z,S,P,_,_)),

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,0))).

op(174)

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)),

get_mem(H,L,M),

bit_xor(A,M,X),

adjust_flags(A,X,Y,flags(Z,S,P,_,_)),

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP # flags(Z,S,P,0,0))).

op(175)

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), bit_xor(A,A,X),

adjust_flags(A,X,Y, flags (Z,S,P,_,__)),

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,0))).

op(l76)

acc_jnath(/\ ,b),!.

op(177)

acc_math(/\,c),!.

op(178)

acc_math(/\,d),1.

op(179)

acc_math(/\,e),!.

/a ORA E a/\

op(180)

acc_math(/\,h),!.

/a ORA Ha/

op(181)

op(182)

acc_math(/\,l),!.

retract(state(regs(A,B,C,D l E,H,L),PC,SP,_)), get_mem(H,L,M),

X is A / \ M,

adjust_flags(A,X,Y,flags(Z,S,P,_,_)),

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,0))).

op(183)

retract(state(regs(A,B,C,D # E,H,L),PC # SP,_)), adjust_flags(A,A,Y,flags(Z,S,P,_,_)),

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,0))).

op(184)

comp_regs(b),!.

/a CMP B a/

op(185)

comp_regs(c),!.

/a CMP C a/

op(186)

comp_regs(d),!.

/a CMP Da/

op(187)

comp_regs(e),I.

/a CMP E a/

op(188)

comp_regs(h),!.

/a CMP H*/

op(189)

comp_regs(l),!.

/a CMP La/

op(190)

/a CMPM a/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), get_jnem(H,L,Q),

X is A-Q,

adJust_flags(A,X,_,Flags),

asserta(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)).

op(191) /a CMP A a/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), adJust_flags(A,0,_,Flags),

asserta(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)).

op(192) /a RNZ */

(not zero_flag_is_set, return); true.

op(193) /» POPB a/

retract(state(regs(A,_,D,E,H,L),PC,SP,Flags)), get_jnem(SP,C),

Hi is SP 4-1, get_mem(Hi,B),

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 63

op(194)

NewSP isSP + 2,

asserta(state(regs(A,B,C,D,E,H,L),PC,NewSP,Flags)).

/*JNZ*/

(not zero_flag_is_set, jump); carry_on.

op(195)

/# JMP #/

Jump.

op(196)

/#CNZ*/

(not zero_flag_is_set, call); carry_on.

op(197)

/# PUSH B #/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)),

Hi is SP-1, put_mem(Hi,B),

Lois SP-2, put_mem(Lo,C),

NewSP isSP-2,

asserta(state(regs(A,B,C,D,E,H,L),PC,NewSP,Flags)).

op(198)

/# ADI D8 */

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), get_mem(PC,Q),

XisA + Q,

ad j us t_f lags (A, X, Y, Flags),

NewPC is PC + 1,

asserta(state(regs(Y,B,C,D,E,H,L),NewPC,SP,Flags)).

op(199)

/*RST0*/

reset(0).

op(200)

/* RZ */

(zero_flag_is_set, return); true.

op(201)

/*RET*/

return.

op(202)

/*JZ#/

(zero_flag_is_set, Jump); carry_on.

op(204)

/* CZ */

(zero_flag_is_set, call); carry_on.

op(205)

/# CALL #/

call.

op(206)

1* ACIDS *1

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flagsCY,_))), get_mem(PC,Q),

X is A + Q + CY,

adj ust_flags(A,X,Y,Flags),

NewPC is PC + 1,

asserts(state(regs(Y,B,C,D,E,H,L),NewPC,SP,Flags)).

op(207) :

/*RST1#/

reset(1).

op(208) :

/* RNC */

(not carry_flag_is_set, return); true.

op(209) :

/*P0PD*/

retract(state(regs(A,B,C_,_,H,L),PC,SP,Flags)), get_mem(SP,E),

Hi is SP + 1, get_mem(Hi,D),

NewSP isSP + 2,

asserts(state(regs(A,B,C,D,E,H,L),PC,NewSP,Flags)).

op(210) :

/#JNC#/

(not carry_flag_is_set, Jump); carry_on.

op(211) :

/ * OUT * /

not_implemented.

64 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

L_

op(212) /* CNC */

(not carry_flag_is_set, call); carry_on.

op(213) /# PUSH D */

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)),

Hi is SP-1, put_jnem(Hi,D),

Lo is SP-2, put_jnem(Lo,E),

NewSP is SP-2,

asserta(state(regs(A,B,C,D,E,H,L),PC,NewSP,Flags)).

op(214) /*SUID8*/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), get_mem(PC,Q),

X is A-Q,

ad j ust_flags(A,X,Y,Flags),

NewPC is PC + 1,

asserta(state(regs(Y,B,C,D,E,H,L),NewPC,SP,Flags)).

op(215) /# RST2 # /

reset(2).

op(2l6) /« HC */

(carry_flag_is_set, return); true.

op(218) l*JC*l

(carry_flag_is_set, jump); carry_on.

op(219) /* IN */

not_implemented.

op(220) /* CC */

(carry_flag_is_set, call); carry_on.

op(222) /* SBI #/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flagsCY,_))), get_mem(PC,Q),

XisA-Q-CY,

adj ust_flags(A,X,Y,Flags),

NewPC is PC + 1,

asserta(state(regs(Y,B,C,D,E,H,L),NewPC,SP,Flags)).

op(223) /*RST3*/

reset(3).

op(224) /* RPO odd parity; flag is 0 #/

(not parity_flag_is_set, return); true.

op(225) /# POP H *1

retract(state(regs(A,B,C,D,E,_,_),PC,SP,Flags)), get_mem(SP,L),

Hi is SP + 1, get_mem(Hi,H),

NewSP is SP + 2,

asserta(state(regs(A,B,C,D,E,H,L),PC,NewSP,Flags)).

op(226) /*JPO odd parity; flag is 0*/

(not parity_flag_is_set, Jump); carry.on.

op(227) /# XTHL #/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)), get_mem(SP,NewH), put_mem(SP,H),

SP1 is SP + 1, get_mem(SPl,NewL), put_mem(SPl,L),

asserta(state(regs(A,B,C,D,E,NewH,NewL),PC,SP,Flags)).

op(228) /* CPO odd parity; flag is 0 »/

(not parity_flag_is_set, call); carry_on.

op(229) /* PUSH H #/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)),

Hi is SP-1,

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 65

put_mem(Hi,H),

Lo is SP-2, put_mem(Lo,L),

NewSP is SP-2,

asserts(state(regs(A,B,C,D,E,H,L),PC,NewSP,Flags)).

op(230) /* ANID8*/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), get_mem(PC,M),

X is A/\ M,

adj ust_flags(A,X,Y,Flags),

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,Flags)).

op(23l) /*RST4*/

reset(4).

op(232) /# RPE odd parity; flag is 1#/

(parity_flag_is_set, return); true.

op(233) /*PCHL*/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)), decompose (PC, PCH, PCL), % (i,o,o) decompose (NewPC,H,L), fc(o,i,i)

asserta(state (regs(A, B, C, D, E, PCH, PCL), NewPC,SP, Flags)).

op(234) /* JPE odd parity; flag is 1 #/

(parity_flag_is_set, Jump); carry_on.

op(235) i- /# XCHG#/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)), asserta(state(regs(A,B,C,H,L,D,E),PC,SP,Flags)).

op(236) /# CPE odd parity; flag is 1 #/

(parity_flag_is_set, call); carry_on.

op(238) :- /*XRID8*/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)),

get_mem(PC,M),

bit_xor(A,M,X),

adjust_flags(A,X,Y,flags(Z,S,P,_,_)),

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,0))).

op(239) /* RST 5 */

reset(5).

op(240) I* RP sign flag is 0 #/

(not sign_flag_is_set, return); true.

op(24l) /* POPPSW */

retract(state(regs(_,B,C,D,E,H,L),PC,SP,_)), get_mem(SP,Flags),

Hi is SP + 1, get_mem(Hi,A),

NewSP is SP + 2,

Sis (Flags/\ 128) / 128,

Z is (Flags /\ 64) / 64,

AC is (Flags/\ 16) / 16,

P is (Flags /\ 4)/ 4,

CY is Flags/\ 1,

asserta(state(regs(A,B,C,D,E,H,L),PC,NewSP,flags(Z,S,P,CY,AC))).

op(242) <* JP sign flag is 0 */

(not sign_flag_is_set, jump); carry_on.

op(243) /*DI#/

not_implemented.

op (244) j * CP sign flag is 0 */

(not sign_flag_is_set, call); carry_on.

op(245) /* PUSH PSW */

retract(state(regs(A,B,C,D,E,H,L),PC,SP,flags(Z,S,P,CY,AC))),

Hi is SP-1, put_mem(Hi,A),

Lo is SP-2,

66

BYTE LISTINGS SUPPLKMKNT • JULY SEPTEMBER. 1987

Flags isCY*l + P*4 + AC*l 6 + Z*64 + S# 128, put_mem(Lo,Flags),

NewSP isSP-2,

asserta(state(regs(A,B,C,D,E,H,L),PC,NewSP,flags(Z,S,P,CY,AC))).

op(246) /*0RID8#/

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), get_mem(PC,M),

X is A/\ M,

adj ust_flags(A,X,Y,flags(Z,S,P,_,_)),

asserta(state(regs(Y,B,C,D,E,H,L),PC,SP,flags(Z,S,P,0,0))).

op(247) /# RST 6 */

reset( 6 ).

op(248) /* RM sign flag is 1 foj

(sign_flag_is_set, return); true.

op(249) /* SPHL #/

retract(state(regs(A,B,C,D,E,H,L),PC,Flags)), decompose (SP,H,L), *(o,i,i)

asserta(state(regs(A,B,C,D,E,H,L),PC,SP,Flags)).

op(250) /# JM sign flag is 1 */

(sign_flag_is_set, jump); carry.on.

op(251) /* El */

not_implemented.

op(252) /* CM sign flag is 1 #/

(sign_flag_is_set, call); carry_on.

op(254) /* CPI D 8 */

retract(state(regs(A,B,C,D,E,H,L),PC,SP,_)), get_mem(PC,Q),

X is A - Q,

adj ust_flags(A,X,Y,Flags),

NewPC is PC 1,

asserta(state(regs(A,B,C,D,E,H,L),NewPC,SP,Flags)).

op(255) /* RST 7 # /

reset(7).

op(_) write( 'undefined opcode'), nl.

%

*end: OPS8085.ARI

HELP80.ARI Contributed by Alex Lane. Accompanies the article "Simulating a Microprocessor," August 1987, page 161.

% File: HELP80.ARI

%

% "nondestructive" help - saves the screen while you access help info.

%

% There's nothing here that can't be done with most Prolog implementations; here, we use Arity's region_ca/\3>

% tget/2, and tmove/3 predicates to save the screen, save the cursor position, and restore the cursor position.

% If your Prolog doesn't implement these features, they can be excised with no great harm done.

%

% Arity/Prolog encloses strings within '$' characters, so this part may require some minor rewrite to work with other % Prolog implementations.

%

%

help grab(S,R,C),write($HELP

Commands can be entered as one or two unique letters (' t' for ' trace', f sh' for ' show'), or as complete words (' step').

All numbers input by the user are assumed to be base 16 (hexadecimal) numbers. This means, for example, that the command 'step 10' is a request for 16 steps, not 101

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 67

Hexadecimal numbers that start with a letter must be typed in with a leading zero (e.g., ' ff' must be typed in as 'Off ).

Additional help is available for the following commands:

status change trace quit

show reset step

To get additional help, type 'help 1 and the command word you are interested in.

$), let_go(S,R,C).

help(status) grab(S,R,C),write($STATUS

This command prints the state/4 clause to the screen. The information displayed by state/4 is not as "pretty' 1 as that shown by the 'show' command, but is complete.

$), let_go(S,R,C).

help(help) :-help.

help(show) grab(S,R,C),write($SHOW

Use this command to display the contents of a register, of a register-pair pointer, and of memory.

To display the contents of a register or of a register pair, type 'show' followed by the appropriate name.

If no parameters are supplied, 16 bytes of memory are shown starting at the current PC value. If only one memory address is specified, only the contents of that address will be displayed.

Examples:

show b Show contents of register b

show be Show contents of address pointed to by be

show Show contents of PC through PC + 16 (decimal)

show 0020 Show contents of address 0020

show 0020 002f Show contents of addresses 0020 through 002f

$), let_go(S,R,C).

help(change) :- grab(S,R,C),write($CHANGE

Use this command to change the contents of a register, of an address in memory, or of an address pointed to by a 16-bit register.

To change something, type 'change' followed by the appropriate register name or memory location, followed in turn by the new value.

Examples:

change 002c 3f Changes the contents of address 002c to 3f

change d 2c Changes the contents of register d to 2c

change pc 0f3 Changes the contents of the program counter to 0f3

$), let_go(S,R,C).

help(reset) grab(S,R,C),write($RESET

This command resets everything back to the initial state:

state(regs(0,0,0,0,0,0,0),0,255,flags(0,0,0,0,0))

$), let_go(S,R,C).

help(step) :- grab(S,R,C),write($STEP

This command causes an instruction to be executed. Multiple instructions can be stepped by adding a second, numeric argument. Examples:

step Steps through one instruction

step 3 Steps through three instructions

step 10 Steps through 16 instructions

$), let_go(S,R,C).

help(my_trace) :- grab(S,R,C),write($TRACE

68 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

Like 'step', this command causes one instruction to be executed, but also displays the processor state upon completion. Multiple traces can be performed by adding a second, numeric argument.

Examples:

trace Steps through an instruction and shows all

trace 3 Steps and shows all through three instructions

trace 10 Steps and shows all through 16 instructions

$), let_go(S,R,C).

help(quit) grab(S,R,C),write($QUIT

This command brings you back to Prolog's '?-' prompt.

$), let_go(S,R,C).

%

% grab/1 takes advantage of an Arity/Prolog predicate that reads characters and their attributes from the screen and places % them in a string. This in effect saves the screen while you are off getting help.

%

% let_go/l waits for the user to strike a key and then restores the screen to the way it looked before the help session.

%

% if you don't mind losing the screen contents when you seek help, you can dispense with these predicates.

%

grab(S,R,C) : — tget(R,C),

region_ca( (0,0), (24,79), S), els, !.

let_go(S,R,C) write($Strike a key to continue ... $), getO(Ch), els,

region_ca( (0,0), (24,79), S), tmove(R,C), !.

% end

PREDS80.ARI Contributed by Alex Lane. Accompanies the article "Simulating a Microprocessor," August 1987, page 161.

% Subject: PREDS80.ARI - from Alex Lane: "Simulating a Microprocessor"

% bit_xor(A,B,C) :: C is exclusive-or of A and B

%

bit_xor(0,0,0) :- !.

bit_xor(0,l,l) !.

bit_xor(l,0,l) !.

bit_xor(1,1,0) :- 1.

bit_xor(A,B,X) :

AA0 is A / / 2, A0 is A mod 2,

BB0 is B / / 2, B0 is B mod 2,

bit_xor(AA0,BB0,XX0), bit_xor(A0,B0,X0),

X is 2 # XX0 + X0.

% adjust_flags( In, Out, flags(Z,S,P,CY,AC)) :: In —> Out and flags checked.

*

adJust_flags(A,In, Out, flags(Z,S,P,CY,AC)) check_carry( In, Out, CY ), check_zero(0ut,Z), check_parity(Out,P), check_aux_carry(A,Out,AC), check_sign(Out,S).

X carry_on :: PC <— PC + 2.

%

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 69

carry_on

retract(state(Regs,PC,SP,Flags)),

NewPC is PC+ 2,

asserta(state(Regs,NewPC,SP,Flags)).

% check_zero(A,B) :: A == 0 —> B == 1, else B == 0.

%

check_zero( 0 ,l) !. check_zero(_, 0 ).

% check_parity(X,Y) :: Y reflects odd parity of number of bits inX.

check_parity(X, Y) par(X,T), Y is T mod 2, !.

par( 0 , 0 ) !.

par(l,l)

par(N,P) :-J is N mod 2,

K is N / / 2, par(K,Pl),

P is J + Pl.

check_sign(X,l) :-X>127, !. check_sign(_, 0 ).

check_carry(In,Out,l) In > 255# Out is In - 255# !. check_carry(In,Out,l) :-In<0, Out is In+ 255, !. check_carry(In, ln, 0 ).

check_aux_carry(01dAccum, NewAccum, 1)

OldAccum / \ 24 =: = 8, % old bit 3 on and old bit 4 off

NewAccum /\ 24 *:■ 16,1. % new bit 4 on and new bit 3 off

% (=: = evaluates both sides and tests for equality)

check_aux_carry(_,_, 0 ) I. zero_flag_is_set

state(_,_,_, flags( 1 ,), ! • sign_flag_is_set

state(_,__, — , flags 1 ,), I •

parity_flag_is_set pstate(_,_,_,flags(_,_,l,!.

carry_flag_is_set

state(_,_,_,flags(_,_,_,l,_)), !.

aux_carry_flag_is_set

state(_,_,_,flags(_, 1 )), !.

% reset (N) :: store PC on stack, PC <-- 8 * N.

%

reset(N)

retract(state(Registers,PC,SP,Flags)), decompose(PC,PCH,PCL),

Hi is SP-1, put_jnem(Hi,PCH),

NewSP is SP - 2, pu t_jnem (NewSP, PCL),

NewPC is 8 * N,

asserta(state(Registers,NewPC,NewSP,Flags)).

% return :: pop PC off stack, adjust SP.

%

return

retract(state(Registers,_,SP,Flags)), get_mem(SP,PCL),

Hi is SP + 1, get_mem(Hi,PCH),

PC is 256 * PCH + PCL,

NewSP isSP + 2,

asserta(state(Registers,PC,NewSP,Flags)).

70 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

jump

retract(state(Registers,PC,SP,Flags)), get_mem(PC,PCL),

Hi is PC + 1, get_jnem(Hi,PCH),

NewPC is 256 * PCH + PCL,

asserta(state(Registers,NewPC,SP,Flags)).

call

retract(state(Registers,PC,SP,Flags)),

PCNisPC + 2, X here? or on return?

PCH is PCN / / 256,

PCL is PCN mod 256,

SP1 is SP - 1,

SP2 is SP - 2, put_mem(SPl,PCH), put_mem(SP2,PCL), get_mem(PC,NPCL),

Hi is PC + 1, get_mem(Hi,NPCH),

NewPC is 256 * NPCH + NPCL, asserta(state(Registers,NewPC,SP2,Flags)).

% put_mem( H, L, Data) :: store Data in Address <— 256 # H + L.

%

put_mem( Hi, Lo, NewData )

Address is 256 * Hi + Lo, put_mem(Address, NewData).

X put_mem( H, L, Data) :: store Data in Address.

%

put_mem(Address,NewData)

retract(memory(Address,_)), asserta(memory(Address,NewData)).

X getjnem( H, L, Data) :: fetch Data in Address <~ 256 * H + L.

X

get_mem(Hi, Lo, Data )

Address is 256 * Hi + Lo, get_mem(Address,Data).

X get_mem( Address, Data) :: fetch Data in Address.

X

get_mem(Address, Data)

memory(Address,Data).

X decompose (Address, Hibyte, Lobyte) :: Address <— 256 # Hibyte + Lobyte

X (o,i,i)

X

decompose (Address, Hibyte, Lobyte) : - X (o, i, i)

var(Address), X if Address is uninstantiated

Address is 256 # Hibyte + Lobyte.

X decompose (Address, Hibyte, Lobyte) :: Address --> Hibyte ; Lobyte

X (i,o,o)

X

decompose (Address, Hibyte, Lobyte) *(i,o,o)

F is Address / 256,

H is integer(F),

Hibyte isH/\ 255,

G is Address - 256 # H,

Lobyte is integer(G).

put_address(Lo) X write an address in hex

decompose(Lo,LoH,LoL), dec_hex_byte(LoH,LHH), dec_hex_byte(LoL,LLH), write(LHH),write(LLH),write(' : •),!.

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 71

% Decimal-to-hex and hex-to-decimal conversions.

dec_hex_byte( Dec, Hex ) :- % (i,o)

var(Hex),!,

Dec < 256,

Hi is Dec >> 4,

Lois Dec /\ 15,

d_h(Hi,H),

d_h(Lo,L),

list_text([H,L],Hex).

dec_hex_byte( Dec, Hex ) % (o,i)

list_text([H,L],Hex), d_h(Hi,H), d_h(Lo,L),

Dec is 16 # Hi + Lo,!.

d_h( In, Out) % (i,o)

In< 10 ,

Out is In + 48.

d_h( In, Out) % (i,o)

Out is In + 55.

d_h( Out, In ) :- % (o,i)

In <65,

Out is In - 48.

d_h( Out, In ) *(o,i)

In <71,

Out is In - 55.

min(II,II, 12) II =< 12, !.

min(I2,Il,I2) :-I2< II.

for(X,X,X) :- !. for(X,Y,X).

for(X,Y,Z) XI isX + 1, for(Xl,Y,Z).

append([H | T], L, [H | R]) :-!, append(T, L, R). append([ ], L, L).

valid_adr(H,L) top_of_memory(TOM), TOM >= (256 # H + L).

reg(a,l). reg(b,2). reg(c,3). reg(d,4).

reg(e,5). reg(h,6). reg(l,7).

fl(z,l). fl(s,2). n(p,3) . fl(cy,4). fl(ac,5).

%

% end: PREDS80.ARI

PARSE80.ARI Contributed by Alex Lane. Accompanies the article "Simulating a Microprocessor," August 1987, page 161.

% Subject: PARSE80.ARI - from Alex Lane: "Simulating a Microprocessor"

% Use DCG to parse a command (request) from the simple monitor.

%

% Intended to be used with TOKENS. ARI (5/10/86)

%

% Basically want to implement following commands:

%

%

% change memory-address-value

% +— register-contents-value

% +— register-pair-pointer-value

% help (a screen of help)

% quit (back to DOS)

% reset (all parameters to some intial state)

Examples:

(change 002 c 30 (change d 2 c) (change pc 0 f 3 ) (help)

(quit)

(reset)

72 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

% show —+— register-contents % +— contents of register-pair-pointer

t +— <memory, no range specified

% +— starting-memory-address

% +— starting-address — ending-address

% step % trace %

(show b)

(show be)

(show)

(show 0020) (show 0020 002f) (step)

(trace)

parse_tokens(change(Adr,Val)) —> verb(change), address(Adr), byte(Val).

parse_tokens(change(Reg,Val)) —> verb(change), register_name(Reg), byte(Val).

parse_tokens(change(RegPair,Val)) —> verb(change), pointer(RegPair), byte(Val).

parse_tokens( change (Flag, Value)) —> verb(change), flag(Flag), flag_value (Value).

parse_tokens( show (Reg)) — > verb(show), register_name(Reg).

parse_tokens( show (Group)) —> verb(show), group_des ignat ion (Group).

parse_tokens(show(RegPair)) —> verb(show), pointer(RegPair).

parse_tokens (show (Start, End)) —> verb(show), address (Start), address(End),

{ Start =< End } .

parse_tokens( show (Start)) — > verb(show), address (Start).

parse_tokens(help(Topic)) —> verb(help), verb(Topic).

parse_tokens( step (Times)) — > verb(step), byte(Times).

parse_tokens(my_trace(Times)) — > verb(my_trace), byte(Times).

parse_tokens(Command) —> verb(Command), { Command \ = = change }.

address(Adr) —> [Adr], { Adr>= 0, top_of_memory(TOM), Adr =< TOM }.

byte(Val) —> [Val], { Val >* 0, Val <256 }.

flag_value(X) —> [X], { X == 1; X == 0 }.

register_name(a) —> [a]. register_name(b) —> [b],

register_name(c) — > [c]. register_name(d) —> [d].

register_name(e) —> [e]. register_name(h) —> [h].

register_name(l) —> [1], register_name(flags) —> [f];[fl];[flags].

flag(z) —> [z]. flag(s) —> [s]. flag(p) —> [p].

flag(cy) —> [cy]. flag(ac) —> [ac].

group_designation(all) — > [al];[all]. group_designation(regs) — > [r]j[re];[regs]. group_designation(stack) —> [st];[stack].

pointer(bc) —> [be]. pointer(de) —> [de].

pointer(pc) —> [p];[pc]. pointer(sp) —> [s];[sp]. pointer(hl) —> [hi];[m];[me];[mem].

verb(change) —> [c];[ch];[change];[set]. % ’set' is a synonym

verb(status) —> [state]. % must say 'state'

verb(help) —> [h];[he];[help].

verb(quit) —> [q];[qu];[quit].

verb(show) —> [sh];[show],

verb(step) —> [st];[step],

verb(my_trace) —> [t];[tr];[trace].

verb(reset_processor) — > [r];[re];[reset].

% end PARSE80.ARI

continued

BYTE LISTINGS SUPPLEMENT * JULY-SEPTEMBER, 1987 73

MON80. ARI Contributed by Alex Lane. Accompanies the article "Simulating a Microprocessor," August 1987, page 161.

% Subject: M0N80.ARI - from Alex Lane: "Simulating a Microprocessor"

% state(_) needs to have been asserted.

% memory must be initialized (so we need 'memory')..

quit :- write('Quitting.'), nl, abort.

step :- step(l),!.

step(N) :- for(l,N,X), execute_instruction, N == X, !.

status :-state(R,P,S,F), write(state(R,P,S,F)), nl.

my.trace :- my_trace(l).

my_trace(N) for(l,N,X), execute_instruction, show(all), nl, N == X.

reset_processor :

retract(state(_,),

asserta(state(regs(0,0,0,0,0,0,0),0,254,flags(0,0,0,0,0))).

change (Adr, Val) :

number(Adr),!, put_mem(Adr,Val).

change (Reg, Val) :

reg(Reg,X),!, retract(state(R,P,S,F)), argrep(R,X,Val,NewR), asserta(state(NewR,P,S,F)).

change(Flag, Val) :

fl(Flag,X),!, retract(state(R,P,S,F)), argrep(F,X,Val,NewF), asserta(state(R,P,S,NewF)).

change(pc, P) :

!, retract(state(R,_,S,F)), asserta(state(R,P,S,F)).

change(sp, S) :

!, retract(state(R,P,_,F)), asserta(state(R,P,S,F)).

change(bc, Val)

!, state(R,

arg(2,R,B), arg(3,R,C),

ifthen( valid_adr(B,C), put_mem(B,C,Val)).

change(de, Val) :

!, state(R,

arg(4,R,D), arg(5,R,E),

ifthen( validLadr(D,E), put_mem(D,E,Val)).

change (hi, Val) :

!, state(R,_,_,_),

arg(6,R,H), arg(7,R,L),

ifthen( valid_adr(H,L), put_mem(H,L, Val)).

show(Reg) :

reg(Reg,X), state(R,_,_,_),

arg(X,R,T), dec_hex_byte( T,HT),

tab(l), concat( [Reg,' (',HT,')' ],Y) ,write(Y),!.

74 BYTK LISTINGS SUPPLHMKNT • JULY-SEPTEMBER, 1987

show(bc)

state(R,

arg(2,R,B), arg(3,R,C),

ifthenelse( valid_adr(B,C),

(get_mem(B,C,D), dec_hex_byte(D,DH)),

DH = $xx$),

concat(['bc>',DH,'< »],Y), write(Y), !.

show(de)

state(R,_,_,__), arg(4,R,D), arg(5,R,E),

ifthenelse( valid_adr(D,E),

(get_mem(D,E,Dl), dec_hex_byte(Dl,DH)),

DH = $xx$) ,

concat(['de>',DH,'< '],Y), write(Y), !.

show(hi)

state(R,

arg(6,R,H), arg(7,R,L),

ifthenelse( valid_adr(H,L),

(get_mem(H,L,D), dec_hex_byte(D,DH)),

DH = $xx$),

concat([ , hl>’,DH,'< ’]# Y )# write(Y), !.

show(pc)

state(_,P,_,_), dec_hex_byte(P,PH), concat(['pc>',PH,'< ']»Y), write(Y), !.

show(sp)

state(_,_,S,_), dec_hex_byte(S,SH), concat([’sp>’,SH,'< »],Y), write(Y), 1.

show(regs)

% show registers and pointers

show(a), show(b), show(c), show(d), show(e), show(h), show(l), write(': ')# show(bc), show(de), show(hl), show(pc), show(sp).

show(all)

% show registers, pointers, and flags show(regs), nl, show(flags).

show(flags)

% show flags only.

state(_,_,_,flags(Z,S,P,CY,AC)),

write(' z = 1 ) ,write(Z), write(»; s » '), write(S), write( 1 ; p = '), wrlte(P), write('; cy = '), write(CY), write( f ; ac = '), write(AC).

show(stack)

state(_,_,S,_), SI is S + 15, top_of_memory(TOM), min(S2,Sl,T0M), show(S,S2).

show(Mem)

% show a single memory location's contents. show(Mem, Mem),!.

show

% starting with current PC address, show 16 bytes. state(__,P,_,J,

top_of_memory(TOM), T0M_1 is TOM - 1,

End is P + 15, min(Q,TOH_l, End), show(P,Q),!.

show(Lo, Hi)

% show specified memory range. number(Lo), number(Hi),

Diff isHi-Lo + 1, show_mem(Diff, Lo),!.

show_mem(0,_)

!.

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 75

show_mem(Left, Start)

min(X,l6,Left),

NewLeft is Left-X, put_address(Start),

dec(X,XO), % because we are going to use zero indexing

for(0,X0,Y),

[! Adr is Start + Y, get_mem(Adr,Data), dec_hex_byte(Data,DH), write(DH),tab(l) !],

XO == Y, nl, !,

NewAdr is Start + X, show_mem(NewLeft,NewAdr).

%

% end: M0N80.ARI

STARTUP.C Contributed by Joel West. Accompanies the review "Macintosh C Compilers Revisited," August 1987, page 219.

/# Listing 9: Standard startup source #/

/* startup.c #/ tfifdef HYPERC

/ # Won 1 1 create window for us # /

s tdTerm (PStr (" Hyper-C w indow ")); EXTERN CHAR getKey( );

^define getchar() getKey(TRUE) tfendif

0ifdef MPU68000

I* Aztec needs this #/

pascal long TickCount() = 0xa975;

#endif

I* Start timing #/ long time;

puts("Press any key to begin timed test: "); getchar();

puts("\nStarting\n"); time = TickCount();

MEMORY.ARI Contributed by Alex Lane. Accompanies the article "Simulating a Microprocessor," August 1987, page 161.

% File: MEMORY.ARI

%

% Note:

% Since this file is very repetitious, only a small portion of the % file is represented here.

% You can generate a complete copy of the file by running the % bas ic program MEMORY. BAS

*

t

%

% This file contains a predicate that initializes a 256-byte memory % (shades of the mid-70s!).

% To "run" a program on the simulated microprocessor, insert the % appropriate machine code bytes into the memory locations

%

init_mem :

asserts(top_of_memory(255 )), assertz(memory(0,0)), % NOP

assertz(memory(l,0)), % NOP

assertz(memory(2,0)), % NOP

76 BYTE LISTINGS SUPPLEMENT • JULY SEPTEMBER. 1987

assertz(memory(3,0)), % NOP

assertz(memory(4,0)), % NOP

% ...

assertz(memory(253>0)), % NOP

assertz(memory(254,0)), % NOP

assertz(memory(255,0)). % NOP

%

X end

TOKENS80.ARI Contributed by Alex Lane. Accompanies the article ’’Simulating a Microprocessor," August 1987, page 161

% Subject: T0KENS80.ARI - from Alex Lane: "Simulating a Microprocessor"

% This version of get_token_list(_) assumes all input numbers are in % hexadecimal and delivers decimal numbers in the output; i.e.,

X entering 'show Of' results in [show, 15].

get_token_list(Result)

read_line(0,String), list_text([Char|Tail],String), tokenize([Char|Tail], [], Result).

% read a sentence from the terminal % read a line of input from the console

tokenize([H|T],List,L)

letter(H, Letter),!, restword(T,[Letter],Word,Rem), append(List,[Word],Nlist), tokenize(Rem,Nlist,L).

X if head of list starts with letter

X get the rest of a word

X recurse, tokenize rest of list

tokenize([H|T], List, L)

digit(H),!,

rest_num(T, [H] ,Num, Rem), append(List,[Num],Nlist), tokenize(Rem,Nlist,L).

% if head of list starts with digit (0-9)

% get a number (Num will be decimal)

% recurse, tokenize rest of list

tokenize([_|T], List, L)

l, tokenize(T,List,L).

X if head of list is not letter or digit,

X ignore it.

tokenize([],List,List).

X stop recursion.

restword( [H|T], List, Word, X )

letter( H, Letter ),!,

append( List, [Letter], Nlist),

restword( T, Nlist, Word, X ).

restword( [32|T], List, Word, T ) :name( Word, List ),!.

restword( [_|T], List, Word, X ) :

!, restword( T, List, Word, X )

restword( [], List, Word, [] )

I, name( Word, List).

rest_num( [H|T], List, Num, X ) :

hexdigit( H,_ ) , !, append( List, [H], Nlist ), rest_num( T, Nlist, Num, X ).

X rest of number may have 0-9, a-f

rest_num( [32|T], List, Num, T )

cname( Num, List, 0 ),!.

X space finishes number, go convert.

rest_num( [],List,Num,[])

!, cname(Num, List, 0).

X nothing left, go convert.

cname( F, [X|[]], N)

!, hexdigit(X,Y), F is N + Y.

X finished.

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 77

cname( Number, [H|T] ,In )

hexdigit(H,Hl),

H2 is (In + HI) * 16, cname(Number, T, H2).

letter(C, C)

0=97, C =< 122, !.

letter(C, D)

0=65, C =< 90, !,

DisC+ 32.

hexdigit(D,E)

digit(D), E is D - 48.

hexdigit(D,F)

letter(D,E), E >= 97, E =< 102,

F is E - 87.

digit(C)

C >= 48, C =< 57. % 48 is "0", 57 is "9".

% convert the input hex number to % a decimal. User need never know!

% recurse with shorter list in T

% 97 is "a", 122 is "z"

% 65 is "A", 90 is "Z"

% 32 is "a"-"A"

%

% end: T0KENS80.ARI

MEMORY.BAS Contributed by Alex Lane. Accompanies the article "Simulating a Microprocessor," August 1987, page 161.

10 ' Program to create MEMORY.ARI File for Prolog program 20 ' for "Simulating a Microprocessor"

30 ' by Alex Lane 40 '

100 OPEN "MEMORY. ARI" FOR OUTPUT AS 1 11OPRINT01, "% File: MEMORY.ARI"

120 PRINT01, "% from Simulating a Microprocessor by Alex Lane" 130 PRINTS, "%"

140 PRINT01, This file contains a predicate that initializes" 150 PRINTS, "* a 256-byte memory"

160 PRINT01, "% To 'run' a program on the simulated microprocessor, 170 PRINT01, "% insert the appropriate machine code bytes into 180 PRINT01, "% the memory locations 190 PRINT01, "*"

200PRINT01, "init_mem

210 PRINTS, " asserta(top_of_jnemory(255)),"

220 FOR I « 0 TO 254 230 IS$ = STR$(I)

240 PRINTS, " assertz(memory("; IS$; ",0)), % NOP"

250 NEXT I

26OPRINT01, " assertz(memory( 255,0)). % NOP"

300 PRINTS, "*"

310 PRINTS, "$ end"

320 CLOSE 400 END

INTERFACED Contributed by Joel West. Accompanies the review "Macintosh C Compilers Revisited," August 1987, page 219.

/# Listing 6: Interface benchmark #/

^define HYPERC /* interface.c */

/# Modified by Joel West, April 14, 1987 for all systems #/

0include <stdio.h> fl if def HYPERC H vnclude <TBXTypes. h>

78 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

0include <events .h> ttelse

ft ifdef MACC H include<macdefs.h>

H include <events.h>

H else

H ifdef AZTEC H include<window.h>

H inc lude < event. h>

H else H ifdef LSC

H include <EventMgr. h>

H endif H endif H endif tfendif

^define COUNT 10000 main()

{ int i, eMaskl, eMask2, booll, bool2;

EventRecord eRcrdl, eRcrd2;

^include "startup.c"

eMaskl = eMask2 = -1; for (i* 0; i< COUNT; ++i)

{ booll = GetNextEvent(eMaskl, &eRcrdl); boo 12 = GetNextEvent(eMask2, &eRcrd2);

booll = GetNextEvent(eMaskl, &eRcrdl); boo 12 = GetNextEvent(eMask2, 8teRcrd2);

booll = GetNextEvent(eMaskl, fceRcrdl); bool2 = GetNextEvent(eMask2, &eRcrd2);

booll = GetNextEvent(eMaskl, &eRcrdl); bool2 = GetNextEvent(eMask2, &eRcrd2);

}

^include "done.c"

}

START80.ARI Contributed by Alex Lane. Accompanies the article "Simulating a Microprocessor," August 1987, page 161.

% START80.ARI - from A. Lane: "Simulating an 8085 with Prolog"

% This file starts everything up. go

write( 'Loadingmemory. '),nl, consult(memory),

vrite(' Initializing memory. ’) ,nl, init_mem,

abolish(init_mem/0),

write(' Loading monitor.'), nl,

consult(mon80),

write(' Loading command parser. ’) ,nl, consult(parse80), write(' Loading tokenizer.'), nl, consult(tokens80),

write( ’ Loading miscellaneous routines.') ,nl, consult(preds80),

write('Loadinghelp information'),nl, consult(help80),

write(' Loading opcode predicates.') ,nl, consult(ops8085 ),

asserta(state(regs(0,0,0,0,0,0,0),0,255 , flags(0,0,0,0,0))),

con l i nurd

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 79

sign_on,

monitor.

% op(_) : - write(' instruction executed').

monitor

repeat,

prompt,

get_token_list(Tokens),

ifthenelse( parse, tokens (Command, Tokens, []), % run command thru DCG. if valid call(Command) , % do it, else

write (* invalid request') ), {{tell user no.

fail.

execute.instruction

retract(state(R,PC,SP,F)),

NewPC is PC + 1,

asserts(state(R,NewPC,SP,F)), get_mem(PC,Instruction), op(Instruction),!.

sign_on

els,

write( *8085 simulator') ,nl, write($Type 'h' for help.$), nl.

prompt

tget(_,Col), % find out what column cursor's in.

ifthen( Col \= 0, nl), % if cursor not in column 0, new line, write('-<'),!. % print prompt.

%

% end START80.ARI

SIEVE.C Contributed by Joel West. Accompanies the review "Macintosh C Compilers Revisited," August 1987, page 219.

/# Listing 1: Sieve benchmark #/

/# sieve.c #/

^define LSC

/* Eratosthenes Sieve prime number program from BYTE, January 1983 Modified by Joel West, April 13, 1987, for 16-bit short

*/

^define REGISTER ^include <stdio.h>

tfifdef HYPERC N inc lude <TBXTypes. h>

^include <events.h> tfendif

^define TRUE 1 ^define FALSE 0 ^define size 8190

/# do program 10 times #/ /# prime counter #/ /# set all flags true #/

/# found a prime */

char flags [size + 1]; main()

{ REGISTER short i, prime, k, count, iter;

^include "startup.c"

for (iter =1; iter <=10; iter++)

{ count = 0;

for (i ■ 0; i<= size; i++) flags [i] = TRUE;

for(i = 0; i<=size; i++)

{ If (flags [1])

80 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

{ prime = 1 + i+ 3; /* twice index + 3 */

for (k = i + prime; k <= size; k+= prime) flags [k] = FALSE; /* kill all multiple #/

count++; / # primes found * /

}

}

^include "done.c"

}

SORT.C Contributed by Joel West. Accompanies the review "Macintosh C Compilers Revisited," August 1987, page 219.

/* Listing 4: Sort benchmark #/

/* sort.c #/

^define LSC

/* sorting benchmark—calls randomly the number of times specified by MAXNUM to create an array of long integers, then does a quicksort on the array of longs. The program does this for the number of times specified by COUNT.

Modified by Joel West, April 13, 1987, for 16-bit short */

^include <stdio.h>

tfifdef HYFERC 0 include <TBXTypes.h>

0include <events. h> tfendif

^define REGISTER

^define MAXNUM 1000 ^define COUNT 10

^define MODULUS ((long) 0x20000)

^defineC13849L ^define A25173L

long seed =* 7L; long random (); long buffer [MAXNUM] = {0};

main()

{ REGISTER short i, J;

REGISTER long temp;

^include "startup.c"

printf ("Filling array and sorting *d times\n", COUNT); for (i = 0; i< COUNT; ++i)

{ for (J = 0; J < MAXNUM; ++J)

{ temp = random (MODULUS);

if (temp< 0L)

temp = (-temp); buffer[J] = temp;

}

printf ("Buffer full, iteration Xd\n", 1); quick (0, MAXNUM - 1, buffer);

}

^include "done.c"

}

quick (lo, hi, base) REGISTER short lo, hi;

am tinned

BYTE LISTINGS SUPPLEMENT

JULY-SEPTEMBER, 1987 81

long base [];

{ REGISTER Inti, j;

REGISTER long pivot, temp;

if (lo < hi)

{ for (i = lo, j = hi-1, pivot = base [hi]; i < J; )

{ while (i< hi &&base [i] <= pivot) .

++i;

while (j > lo && base [J ] > = pivot)

J >

if(i< J)

{ temp = base [i]; base [i] = base [J]; base [J] = temp;

}

}

temp = base [i]; base [i] = base [hi]; base [hi] = temp; quick (lo, i - 1, base); quick (i + 1, hi, base);

}

}

long random (size)

REGISTER long size;

{

seed = seed # A + C; return (seed % size);

}

SAVAGE.C Contributed by Joel West. Accompanies the review "Macintosh C Compilers Revisited," August 1987, page 219.

Note 1

Note 2

Note 3

Note 4

Note 5

Note 6

Note 7

Note 8

Note 9

Note 10

Note 11

Note 12

Note 13

Note 14

Note 15

Note 16

Note 17

Note 18

Note 19

Note 20

Note 21

Note 22

Note 23

tfifdef HYPERC

/'define log(x) ln(x) /* wrong name. Others built in */ tfelse

/'include <math.h>

/fend if

main()

{ inti;

EXTENDED a;

/'include "startup.c"

1) a = 1.0;

for (i = 1; i<= (IL00P-1); i++)

a = tan(atan(exp(log(sqrt(a*a))))) +1.0;

printf("a=*20.l4e\n", a);

/'include "done.c"

FLOAT.C Contributed by Joel West. Accompanies the review "Macintosh C Compilers Revisited," August 1987, page 219.

/# Listing 7: Float benchmark #/

/'define LSC /# float.c*/

/# simple benchmark for testing floating-point speed of c libraries does repeated multiplications and divisions in a loop that is large enough to make the looping time insignificant */

/'include <stdio.h>

/fifdef MACC

/'define EXTENDED extended ttelse

tfifdef HYPERC

/'define EXTENDED extended

/'include <TBXTypes.h>

/'include <events. h>

/'else

/'define EXTENDED double /'end if /'end if

/'define C0NST1 3-141597E0 /'define C0NST2 1.7839032E4 /'define COUNT 10000

main()

{ EXTENDED a, b, c;

int i;

/'include "startup.c"

a = C0NST1; b = C0NST2;

for (i = 0; i< COUNT; ++i)

{ c « a # b; c = c / a; c = a * b; c = c / a; c * a * b; c = c / a; c ■ a # b; c = c/ a; c « a # b;

continued

BYTE LISTINGS SUPPLEMENT

JULY-SEPTEMBER, 1987 83

c * c / a; c = a # b; c = c/ a; c = a # b; c = c / a;

#include "done.c"

}

DONE.C Contributed by Joel West. Accompanies the review "Macintosh C Compilers Revisited," August 1987, page 219.

/# Listing 10: standard termination header #/

/* done.c */

/# End timing*/

time = TickCount() - time; printf("ticks=jtld\n",time); printf("Press any key to return to FINDER: "); getchar();

FiB.C Contributed by Joel West. Accompanies the review "Macintosh C Compilers Revisited," August 1987, page 219.

/# Listing 5: Fib benchmark */

^define LSC /* Fib.c*/

/# Fibonacci benchmark, modified by Joel West, 4/13/87*/

^include <stdio.h>

tfifdef HYPERC 0include <TBXTypes.h>

^include <events.h> tfendif

^define REGISTER

^define NTIMES 10 /* number of times to compute Fibonacci value #/ ^define NUMBER 24 /* biggest one we can compute with 16 bits */

main() /* compute Fibonacci value #/

{ REGISTER short i;

REGISTER unsigned short value; uns igned short f ib ();

#Include "startup.c"

for (1« 1; i <= NTIMES; i++) value = fib(NUMBER );

^include "done.c"

exit(0);

}

unsigned short flb(x) /» compute Fibonacci number recursively */ REGISTER short x;

{ if (x > 2)

84 BYTE LISTINGS SUPPLEMENT • JUl.Y-SEPTEMBF.R. 1987

}

return (fib(x - 1) + fib(x -2)); else

return (1);

FILEIO.C Contributed by Joel West. Accompanies the review "Macintosh C Compilers Revisited,” August 1987, page 219.

/# Listing 8: Fileio benchmark #/

^define LSC /* fileio.c */

/* file reading and writing benchmark sequentially writes a 65,000-byte file on disk, generates random long numbers, and uses

these modulo 65,000 to read and write strings of ODDNUM bytes with the file-handling system of the c package; the random-number generator is set to a specific seed, so that all compilers should generate the same code

Fixed by Joel West, April 16, 1987, to use UNIX-standard creat() and open() parameters.

*/

^include <stdio.h>

tfifdef LSC ^include <unix.h> ftelse

^ifndef MACC /# this is the right way to do it */

^include <fcntl.h>

#endif

tfendif

tfifndef MACC

^define FILEMODE 0666 /# the normal rw-rw-rw */

#else

^define FILEMODE 0x7 /# Mac C only */

^define 0_RD0NLY 0 ^define 0_WR0NLY 1 ^define 0_RDWR 2 0endif

0ifdef LSC

0define abort AbOrT / # Lightspeed C has an ' abort' entry point */

flendif

^define ERROR -1 ^define READERR 0 ^define 0KCL0SE 0

/# For lseek() #/

^define BEG 0 ^define CURR 1 ^define END 2

^define FILESIZE 65000L ^define COUNT 500

^defineC13849L ^define A25173L ^define ODDNUM 23

long seed ■ 7L;

long random (), lseek ();

main ()

{ inti;

long J , pos; int fd;

char buffer [ODDNUM+ 1];

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 85

H include "startup.c"

if ((fd = creat ("test.dat", FILEMODE)) == ERROR) abort ("Can't create data file\n"); else

printf ("File opened for sequential writlng\n");

for (j =0; j< FILESIZE; ++j) if (write(fd, "x", 1) == ERROR) abort ("Unexpected EOF in writing data file\n");

if (close (fd) ! = 0KCL0SE) abort ("Error closing data f ile\n"); else

printf ("Normal termination writing data f ile\n");

if ((fd * open ("test.dat", 0_RDWR)) == ERROR) abort ("Can't open data file for random reading and writing\n"); else

printf ("File opened for random reading and writing\n");

for (1 = 0; i< COUNT;++i)

{ j = random (FILESIZE);

if (J < 0L)

J = (-J);

if (FILESIZE-j < ODDNUM) continue;

if ((pos = lseek (fd, j, BEG)) *■ -1L) abort ("Error reading at random offset\n"); if (read (fd, buffer, ODDNUM) == READERR) abort ("Error reading at random offset\n"); j = random (FILESIZE); if (J < 0L)

J s (-J);

if (FILESIZE- J < ODDNUM) continue;

if ((pos = lseek (fd, J , BEG)) =* -1L) abort ("Error seeking to random offset\n"); if (write (fd, buffer, ODDNUM) == READERR) abort ("Error writing at random offset\n");

}

if (close (fd) ! = 0KCL0SE)

abort ("Error closing data file\n");

else

printf ("Normal termination from random reading and writing\n");

0include "done.c"

}

long random (size)

long size;

{ seed = seed * A + C;

return (seed % size);

}

abort(message) char *message;

{ printf(message);

exit (ERROR);

}

86 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

CHAOSBEN.BAS Contributed by Jerry Pournelle. Accompanies "Computing At Chaos Manor: Faster, Bigger, Better," August 1987, page 243.

The Benchmark Program

REM A benchmark program to test machines, compilers, and languages. REM ** DECLARATIONS

DEFINT I - N DEFINT E DEFDBL A - C DEFDBL S

REM Variable "start$" is a string.

REM #** CONSTANTS

ELEMENTS = 50 SUM = 0

BELL$ = CHR$(7)

REM #*# DIMENSIONS

DIM A(Elements, Elements)

DIM B(Elements, Elements)

DIM C(Elements, Elements)

REM *#* PROGRAM

CLS ' Clear the screen or it' 11 scroll funny

Print "This is a program to fill two matrices of "; print Elements;

print " elements, multiply them, and sum the result." print

print "It can be used as a benchmark program to test ";

print "languages, compilers, or machines."

print

print "Written by Jerry Pournelle, May 1987." print "Not copyrighted."

input "Start timer. Enter any character to begin. ";start$

GOSUB FillA Print "A Filled."

GOSUB FillB Print "B Filled"

GOSUB FillC ' Needed because some compilers can 1 1 cope.

Print "C Filled"

GOSUB DoMultiply Print "Multiplied"

GOSUB SumltUp Print "Sum * "jSum BEEP (5)

END

REM ########**### PROCEDURES ##########

FillA:

FOR i * 1 to Elements FOR J = 1 to Elements A( i#J) ■ i +J NEXT NEXT

RETURN » End FillA

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 87

Chapter Notes

/# Listing 2: Savage benchmark * */

/# savage.c */

^define LSC /*

## savage.c — floating-point speed and accuracy test. C version *# derived from BASIC version that appeared in Dr. Dobb's Journal,

## Sept. 1983, pp. 120-122.

Modified by Joel West, April 14, 1987

For accuracy on the Macintosh, we want to use the SANE 80-bit extended type for all compilers. This is:

Lightspeed C double Mac C extended

Hyper C extended

Aztec C N/A

*1

^define IL00P 2500 0include <stdio.h>

tfifdef MACC

H define EXTENDED extended ^include <sane.h>

0else

tfifdef HYPERC

^define EXTENDED extended

H include <TBXTypes.h>

H include <events.h>

0else

^define EXTENDED double

0endif

tfendif

August

FillB:

FOR i = 1 to Elements

FOR j = 1 to Elements B(i,J)-(i + J) / J NEXT NEXT

RETURN 'End FillB

FillC:

FOR I = 1 = 1 to Elements FOR j = 1 to Elements C(i,J)«0 NEXT NEXT

RETURN ' End FillC

DoMultiply:

FOR 1 = 1 to Elements FOR j = 1 to Elements FOR k = 1 to Elements

C(i,J) *C(i,J) +A(i,k) *B(k,J) NEXT NEXT NEXT

RETURN ' End DoMultiply

SumltUp:

FOR i = 1 to Elements FOR j = 1 to Elements SUM = SUM + C(i,J)

NEXT

NEXT

RETURN ' End SumltUp

Print "ESAD!" ' Shouldn' t be able to get here.

END

88 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

ALSPRO.TST Contributed by Alex Lane. From "ALS Prolog," BYTE, September 1987.

"Translations" of Prolog benchmarks first used on Turbo Prolog.

When running these benchmarks, remember that the read/1 predicate expects to see a period to signal the end of input! Note: All errors from the original set of benchmarks have been fixed.

a.lane (4/17/87)

% Factorial Benchmark Test fact

write ('Enter number of iterations '), read(Iter),nl,

write('Enter factorial number '), read(Num),nl,nl, time(Start), repeat(Iter,Num),

time(Finish) ,nl, Overall is Finish - Start, write('Time is '),write(Overall),nl.

factorial(l,l) !. factorial(N,Result)

N1 isN-1,

factorial(Nl, Temporary),

Result is N * Temporary.

repeat(0,R) write(X),nl. repeat(N,R) factorial(R,_),

N1 isN-1, repeat(Nl,R).

time(Time) :-Time is cputime.

% .

% List-Reversal Test Program lrev

write('Enter cycle length '), read(N), time(Start), cycle(N),

time(Finish), Overall is Finish - Start, write('Time * '),write(Overall),nl.

append( [], L, L).

append( [Z|L1], L2, [Z|L3] ) :-append( LI, L2, L3 ).

lips(L) :-rev([l, 2 , 3 ,4, 5 ,6,7,8,9, 10,11,12, 13 , 14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36, 37,38,39,40,41,42,43,44,45,46,47,48,49,50],L).

llpshort(L) :-rev( [1,2,3,4,5,6,7,8,9,10], L).

rev( [],[]).

rev( [H|T], L) :-rev(T,Z), append( Z, [H], L).

cyele(0).

oycle(N) :-Nl IsN-1, llps(_), oycle(Nl). tlme(Tlme) :-Tlme Is cputime.

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 89

* ---

% Floating-Point Test Program

% This floating-point benchmark is significantly different from the one performed on Turbo Prolog.

*

% The heart of the Turbo benchmark reads:

%

% calc(A,B)

% C is 1.0,

% Cl is C* A,

% C2 is Cl * B,

% C3 is C2 / A,

% C is C3 / B,

% bound(C).

%

% which is flawed for two reasons. First, the value of C is reinitialized each time the predicate calc/2 is called, which defeats % one of the reasons for performing these operations 5000 times: to see if there is any cumulative error. Second, the Turbo % benchmark works only if the result of C3 / B is *exactly# 1.0. If there is any error (i.e., if, as is true with ALS Prolog,

% C3 / B is 1.00000000000000000001) the thing won't fly at all.

float

time(Start),

cycle(5000, 1.0, 2.71828, 3-14159 ), time(Finish), Overall is Finish - Start, write('Time is '),write(0verall),nl.

calc(In,0ut,A,B)

Cl is In * A,

C2 is C1#B,

C3 is C2 / A,

Out is C3/ B.

cycle(0,C,A,B) write('C is ',C),nl.

cycle(N,C,A,B)

calc(C,CF,A,B),

N1 isN-1, cycle(Nl,CF,A,B).

time(Time) :-Time is cputime.

%

% Math Functions Test Program goal

write('Doing square root... '),nl, time(Tl),

eyelesqrt(1000,_,T1), write (' Doing logs..'), nl, time(T2),

cycleln(l000,_,T2), write(' Doing exp..'), nl, time(T3),

eyeleexp(1000,_,T3), write( 'Doing atan.. '),nl, time(T4),

cycleatan(1000,_,T4), write( 'Doing sin...') ,nl, time(T5),

cyclesin(1000,_,T5).

cyclesqrt(0,R,Tl) time(T6), Stime is T6 - Tl,

write('SQRT : '),write(Stime),nl,!.

cyclesqrt(N, R, T)

N > 0, Nl is N - 1, R is sqrt(100.0), cyclesqrt(Nl,R,T).

cycleln(0,R,T2) :-time(T7), Ltime isT7-T2,

write('LN: '),write(Ltime),nl.

cycleln(N, R,T)

N>0, Nl isN-1, R is log (100.0), cycleln(Nl,R,T).

90 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

cycleexp(0,R,T3) :-time(T8), Etime isT8-T3,

write('EXP : *),write(Etime),nl.

cycleexp(N, R,T)

N> 0, N1 is N - 1, R is exp(10.0), cycleexp(Nl,R,T).

cycleatan(0,R,T4) time(T9), Atime is T9 - T4,

write(' ATAN : *),write(Atime),nl.

cycleatan(N, R,T)

N > 0, N1 is N - 1, R is atan(lO.O), cycleatan(Nl,R,T).

cyclesin(0,R,T5) time(TlO), Stime is T10 - T5,

writeOSIN: '),write(Stime),nl.

cyclesin(N, R,T)

N > 0, N1 is N - 1, R is sin(lO.O), cyclesin(Nl,R,T). time(Time) :-Time is cputime.

% Disk Read Program dread

see('a:tempo.dat'),

time(Start),

get_text(512),

time(Finish), Overall is Finish - Start, seen, see(user),

write('Time= 1 ),write(Overall),nl, write('DONE*),nl.

get_text(0). get_text(N)

read(Str),

N1 isN-1, get_text(Nl).

%

% Disk Write Benchmark dwrite

tell('a:tempo.dat’), time(Start), send_text(512),

time(Finish), Overall is Finish - Start, told, tell(user),

write('Time = '),write(Overall),nl, write('DONE'),nl.

sendLtext(O). send_text(N)

write('x2345678123456781234567812345670123456781234567812345678123456701234 56781234567812345678123456701234567812345678123456781234567.'), nl, N1 isN-1, sendLtext(Nl).

time(Time) :-Time is cputime.

*.

% Tower of Hanoi Test Program hanoi

write (' Enter tower height '), read(High), time(Start), hanoi(High),

time(Finish), Overall is Finish - Start, write('Time : '),write(Overall),nl.

hanoi(N) :-move(N, left, center, right).

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 91

move(0 # _, _) !.

move(N, A, B, C)

MisN-1, move(M, A, C, B), move2(bottom. A, B), move(M, C, B, A). move2(bottom, A, B)

write(’Move the disk on ’),

write(A),

write(’ to '),

write(B),

nl.

time(Time) Time is cputime.

% ---

% Sieve Test Program

eratosthenes time(Start), cycle(10),

time(Finish), Overall is Finish - Start, write('Time is '),write(Overall),nl.

primes( Limit, Ps )

integers( 2, Limit, Is ), sift( Is, Ps ).

integers( Low, High, [Low|Rest] )

Low =< High, !, M is Low + 1, integers(M, High, Rest). integers (_,_,[] ).

sift( [], []). sift( [Ills], [l|Ps])

remove(I,Is,New), sift( New, Ps ).

remove(_, [],[]). remove(P, [l|Is], [l|Nis])

I mod P s \ a o, I, remove(P, Is, Nis). remove(P,[l|ls],Nis)

I mod P = := 0, remove(P, Is, Nis).

cycle(O). cycle(N)

Nl isN-1, primes(100,_), cycle(Nl).

time(Time) :-Time is cputime.

% .

% This program is called with the query "?-boresea(X)."

% X is the number of loop iterations executed. It should be big enough to give significant results. % suggested value for X: 100 for interpreted code % 1000 for compiled code

% average values for C-prolog interpreter:

% X=1000, Tloop=27.1 T.compel.0 Tnet=26.1 Klips=7.7

boresea(X)

:-Tl is cputime,

do_max_KLips(X), % calls the loop to execute the

T2 is cputime, % sequence of 200 predicates

compens_loop(X), % compensation loop

T3 is cputime,

print_times(Tl,T2,T3#X,200). % compute and print results

compen8_loop(0). % compensation loop

compens_loop(X) Y is X - 1, compens_loop(Y).

92 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

print_times(Tl,T2,T3,X,I)

X prints the results

TT1 is T2 - Tl, TT2 is T3 - T2, TT is TT1 - TT2,

write('T overall loop: write(*T compens loop:

f ),vrite(TTl), nl, '),write(TT2), nl, *),write(TT),nl, *),

write( ’Tnet: write('KLips: Li is I *X,

Lips is Li / TT,

KLips is Lips / 1000, write(KLips),nl,nl.

do_max_KLips(0).

% loop calling the actual benchmark

do_max_KLips(X) :- lipsl, Y is X - 1, do_max_KLips(Y).

% predicates to test call

lipsl :- lips2.

Iips2 :- lips3.

Iips3 lips4.

Iips4 :- lips5.

Iips5 lips6.

Iips6 :- lips7.

Iips7 :- lips8.

Iips8 :- lips9.

Iips9 lipslO. lipslO lipsll. lipsll lipsl2. lips12 lipsl3.

Iipsl3 lipsl4.

Iipsl4 lipsl5.

Iipsl5 lipsl6.

Iipsl6 lipsl7.

Iipsl7 :-lipsl8.

Iipsl8 :-lipsl9.

Iipsl9 lips20.

Iips20 lips21.

Iips21 :- lips22.

Iips22 lips23.

Iips23 lips24.

Iips24 :-lips25.

Iips25 lips26.

Iips26 lips27.

Iips27 lips28.

Iips28 :- lips29.

Iips29 :-lips30.

Iips30 :- lips31.

Iips31 :-lips32.

Iips32 :-lips33.

Iips33 lips34.

Iips34 :-lips35.

Iips35 :-lips36.

Iips36 :- lips37.

Iips37 :-lips38.

Iips38 :- lips39.

Iips39 :- lips40.

Iips40 :- lips4l.

Iips4l :-lips42.

Iips42 :-lips43.

Iips43 lips44.

Iips44 :- lips45.

Iips45 lips46.

Iips46 :- lips47.

Iips47 :- lips48.

Iips48 :- lips49.

Iips49 lipslO.

Iips50 :- lipsll.

Iips51 :-lips52.

Iips52 :-lips53.

Iips53 :-lips54.

Iips54 :- lips55.

Iips55 :-lips56.

Iips56 :-lips57.

Iips57 :-lips58.

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 93

lips58 :-lips59. Iips59 lips60. Iips60 lips6l. Iips6l lips62. Iips62 lips63. Iips63 lips64. Iips64 :-lips65. Iips65 lips66. Iips66 lips67. Iips67 :-lips68. Iips68 :-lips69. Iips69 :-lips70. Iips70 lips71. Iips71 lips72. Iips72 :-lips73. Iips73 lips74. Iips74 :-lips75. Iips75 :-lips76. Iips76 :-lips77. Iips77 lips78. Iips78 lips79. Iips79 lips80. Iips80 lips81. Iips81 lips82. Iips82 :-lips83. Iips83 :-lips84. Iips84 :-lips85. Iips85 lips86. Iips86 lips87. Iips87 lips88. Iips88 lips89. Iips89 lips90. Iips90 lips91. Iips91 :-lips92. Iips92 :-lips93. Iips93 :-lips94. Iips94 :-lips95. Iips95 lips96. Iips96 :-lips97. Iips97 :-llps98. Iips98 :-lips99. Iips99 lipslOO. lipslOO lipslOl lipslOl lipsl02 lips 102 lipsl03 lipsl03 lips104

lips104 lipsl05 lipsl05 :-lipsl06 lipsl06 lipsl07 lipsl07 lipsl08 lipsl08 lipsl09 lipsl09 lipsllO lipsllO lipslll lipslll lipsll2 lipsll2 lipsll3 lipsll3 lipsll4, lipsll4 lipslll lipsll5 lipsll6. Iipsll6 lipsll7. Iipsll7 lipsll8. Iipsll8 lipsll9. Iipsll9 lipsl20. Iipsl20 lipsl21. lips121 lipsl22.

lips 122 lipsl23«

lips123 lips124.

Iipsl24 :-lipsl25. Iipsl25 lipsl26. lips126 lipsl27. Iipsl27 lipsl28. Iipsl28 lipsl29. lips129 lipsl30. Iipsl30 :-lipsl31. Iipsl31 :-lipsl32. lips 132 :-lipsl33. Iipsl33 :-lipsl34.

lipsl34 :-lipsl35.

Iipsl35 lipsl 36 .

Iipsl36 :-lipsl37.

Iipsl37 :-lipsl 38 .

Iipsl38 :-lipsl39.

Iipsl39 s- lipsl40.

Iipsl40 lipsl4l.

Iipsl4l lipsl42.

Iipsl42 :-lipsl43.

Iipsl43 lipsl44.

Iipsl44 lipsl45.

Iipsl45 lipsl46.

Iipsl46 lipsl47.

Iipsl47 :-lipsl48.

Iipsl48 lipsl49.

Iipsl49 lipsl50.

Iipsl50 lipsl^l.

Iipsl 51 :-lipsl 52 .

Iipsl52 lipsl53* lipsl53 :-lipsl54.

Iipsl54 :-lipsl55.

Iipsl55 lipsl 56 .

Iipsl56 :-lipsl57.

Iipsl57 :-llpsl58.

Iipsl58 ;-llpsl59.

Iipsl 59 lipsl60.

Iipsl60 lipsl 6 l.

Iipsl 6 l lipsl62. lips 162 :-lipsl63.

Ilpsl63 lipsl64.

Iipsl64 :-lipsl65.

Iipsl65 2 - lipsl 66 . lips166 2 - lipsl67.

Iipsl67 :-lipsl 68 .

Iipsl 68 lipsl69. lips169 2 - lipsl70.

Iipsl70 2-lipsl71.

Iipsl71 2 - lipsl72.

Iipsl72 :-lipsl73.

Iipsl73 2 - lipsl74. lips 174 :-lipsl75.

Iipsl75 2 - lipsl76.

Iipsl76 lipsl77.

Iipsl77 2 - lipsl78.

Iipsl78 2 - lipsl79. lips179 2 - lipsl80.

Iipsl80 2 -lipsl 81 .

Iipsl81 lipsl82.

Iipsl82 2 - lipsl 83 .

Iipsl83 2 - lipsl84.

Iipsl84 lipsl85.

Iipsl85 lipsl 86 .

Iipsl 86 2 - lipsl87.

Iipsl87 2 - lipsl 88 .

Iipsl 88 lipsl89. lips189 2 - lipsl90. lips190 2 - lipsl91.

Iipsl91 lipsl92. lips192 lipsl93* lipsl93 :-lipsl94. lips194 lipsl95.

Iipsl95 2 - lipsl96. lips 196 :-lipsl97.

Iipsl97 t- lipsl98^ lips198 2 - lipsl99. lips199 lips 200 .

Iips 200 .

% .

% Choice Point Benchmark.

% The predicates are called:

% o ”choice_point(N)" - creation of choice points

% N is the number of loop iterations executed

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 95

% predicate to test creation of choice points without % backtracking

choice_point(N) T1 is cputime, cre_CP(N), T2 is cputime, compens_loop(N), T3 is cputime, print_times(Tl,T2,T3,N,20).

% compensation loop, used to measure the time spent in % the loop

compens_loop(0).

compens_loop(X) : - Y is X - 1, compens_loop(Y).

% loop to test choice point creation cre_CP(0).

cre_CP(N) :-M is N-l, ccpl(0,0,0), cre_CP(M). cre_CP0ar(0).

cre_CPOar(N) :-M is N-l, ccpl, cre_CPOar(M).

print_times(Tl,T2,T3,X,I)

TT1 is T2-T1,

TT2 is T3 - T2,

TT is TT1-TT2, write(*T overall loop: write(*T compens loop: write( 'T net: write('KLips:

Li is I * X,

Lips is Li / TT,

KLips is Lips / 1000, write(KLips),nl,nl.

% prints the results

, ),write(TTl), nl, '),write(TT2), nl, '),write(TT),nl,

% ccpl creates 20 choice points

% ccpl is the beginning of a set of predicates composed of 2 clauses each. Every invocation of ndO will create % a sequence of 20 choice points. The body of the clauses are limited to one goal, thus avoiding a creation of environment % when the clause is activated. ndO, and its successors, have three arguments to comply with our average static analysis % results made on more than 30 real Prolog programs.

% ccpXX exists with 3 arguments, and 0 args.

ccpl(X,Y,Z):-ccp2(X,Y,Z). ccpl(X,Y,Z).

ccp2(X,Y,Z):-ccp3(X,Y,Z). ccp2(X,Y,Z).

ccp3(X,Y,Z):-ccp4(X,Y,Z). ccp3(X,Y,Z).

ccp4(X,Y,Z):-ccp5(X,Y,Z). ccp4(X,Y,Z).

ccp5(X,Y,Z):-ccp6(X,Y,Z). ccp5(X,Y,Z).

ccp6(X,Y,Z):-ccp7(X,Y,Z). ccp6(X,Y,Z).

ccp7(X,Y,Z):-ccp8(X,Y,Z). ccp7(X,Y,Z).

ccp8(X,Y,Z):-ccp9(X,Y,Z). ccp8(X,Y,Z).

ccp9(X,Y,Z):-ccpl0(X,Y,Z). ccp9(X,Y,Z).

ccpl0(X,Y,Z):-ccpll(X,Y,Z). ccpl0(X,Y,Z).

ccpll(X,Y,Z):-ccpl2(X,Y,Z). ccpll(X,Y,Z).

ccpl2(X,Y,Z):-ccpl3(X,Y,Z). ccpl2(X,Y,Z).

ccpl3(X,Y,Z):-ccpl4(X,Y,Z). ccpl3(X,Y,Z).

ccpl4(X,Y,Z):-ccpl5(X,Y,Z). ccpl4(X,Y,Z).

ccpl5(X,Y,Z):-ccpl6(X,Y,Z). ccpl5(X,Y,Z).

ccpl6(X,Y,Z):-ccpl7(X,Y,Z). ccpl6(X,Y,Z).

ccpl7(X,Y,Z):-ccpl8(X,Y,Z). ccp!7(X,Y,Z).

96 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

ccpl8(X,Y,Z):-ccpl9(X,Y,Z). ccpl8(X,Y,Z).

ccpl9(X,Y,Z):-ccp20(X,Y,Z). ccpl9(X,Y,Z). ccp20(X,Y,Z). ccp20(X,Y,Z).

KAREX3.BAS Accompanies the article "Karmarkar's Algorithm” by Andrew M. Rockett and John C. Stevenson, BYTE, September 1987.

100 '.

101 *

102 * KAREX3. BAS is a Microsoft BASIC Release 5 program

103 * that solves EXAMPLE 3 of the article

104 »

105 ' KARMARKAR * S ALGORITHM

106 •

107 ’ by Andrew M. Rockett and John C. Stevenson

108 *

109 ' This program was written by Andrew M. Rockett

110 1

111 '

200 '

202 ' N is the number of unknowns and K is the number of equations 204 '

206 N = 8 : K = 4 208 '

210 K1 = K + 1 : K2 = 2#K1

212 DIMAO(N), X0LD(N), XNEW(N), CC(N), CP(N), A(K,N), B(K1,N), B1(K1,K2), B2(N,K1), B3(N,N) 214 FOR C = 1 TO N : A0(C) = 1/N : XNEW(C) = A0(C) :

NEXT C

216 '

218 1 T is the tolerance 220 '

222 T= .001 224 '

226 ' ALPHA is usually set equal to 1/4 ...

228 '

230 ALPHA = .25 232 '

234 ITERATION = 0 236 1

238 ' Data for constraint matrix A 240 *

242 DATA 1, 0, -1, 0, 0, 0, 3, -3 244 DATA 1, 0, 0, 1, 0, 0, 0, -2 246 DATA 0, 1, 0, 0, 1, 0, 3, -5 248 DATA 0, 1, 0, 0, 0, -1, 4, -4 250 •

252 FOR R = 1 TO K : FOR C * 1 TO N : READ A(R,C) :

NEXT C : NEXT R

254 '

256 ' Data for objective function CC 258 '

260 DATA 0, 0, 0, 0, 0, 0, 1, 0 262 '

264 FOR C - 1 TO N : READ CC(C) : NEXT C 266 '

268 V = 0 : FOR C=1 TO N : V = V + CC(C)#A0(C) :

NEXT C : VNEW * V

270 '

272 ' Main iteration process is the same as in KAREX1.BAS ...

274 '

300 WHILE VNEW/V>T

301 PRINT USING "###"j ITERATION;:

FOR C*1 TO N:PRINT USING ”###.####" ;XINEW(C); :

NEXT C : PRINT USING #######"; VNEW/V

302 ITERATION - ITERATION + 1

303 FOR C ■ 1 TO N : X0LD(C) = XNEW(C) : NEXT C

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 97

304 FOR R=1 TO K:FOR C=1 TO N:B(R,C)=A(R,C)*XOLD(C):

NEXT C: NEXT R

305 FOR C=1 TO N:B(K1,C)=1:NEXT C

306 FOR R=1 TO K1 : FOR C=1 TO K2 : B1(R,C)=0 :

NEXT C : NEXT R

307 FOR R-l TON : F0RC=1T0 K1 : B2(R,C)=0 :

NEXT C : NEXT R

308 FOR R=1 TO N : F0RC=1T0N : B3(R,C)=0 :

NEXT C : NEXT R

309 FOR C=1 TO N : CP(C) = 0 : NEXT C

310 FOR R=1 TO K1: FOR C=1 TO K1:

FOR 1=1 TO N:Bl(R,C)=Bl(R,C)+B(R,I)#B(C,I):

NEXT I:

NEXT C: NEXT R

311 FOR I = 1 TO K1 : B1(I,I+K1)=1 : NEXT I

312 FOR R = 1 TO K1

313 IF Bl(R,R) <>0 THEN 318

314 I = R + 1

315 IF I > K1 THEN PRINT "Error! BBT is SINGULAR!" :

GOTO 405

316 IFB1(I,R) = 0 THEN I = 1+1 : GOTO 315

317 FOR C = 1 TO K2 : SWAP B1(R,C) ,Bl(I,C) : NEXT C

318 FOR I = R+l TO K1:Z = B1(I,R)/Bl(R,R):

FOR C=1 TO K2:B1(I,C)=B1(I,C)-Z#B1(R,C):NEXTC:

NEXT I

319 NEXT R

320 FOR R=K1 TO 2 STEP -1:FOR I = R-l TO 1 STEP -1:Z = Bl(I,R) /Bl(R,R)

FOR C=R TO K2:B1(I,C)=B1(I,C)-Z#B1(R,C):NEXT C:

NEXT I:NEXTR

321 FOR R=1 TO K1:Z = B1(R,R):

FOR C=1 TO K2:B1(R,C)=B1(R,C) /Z:NEXT C:

NEXT R

322 FOR R=1 TO N: FOR C=1 TO K1:

FOR J=1 TO K1:B2(R,C)=B2(R,C)+B(J,R)#B1(J,C+K1):

NEXT J:

NEXT C: NEXT R

323 FOR R=1 TO N: FOR C=1 TO N:

FOR J=1T0 K1:B3(R,C)=B3(R,C)+B2(R,J)»B(J,C):

NEXT J:

NEXT C: NEXT R

324 FOR R = 1 TO N : B3(R,R) = B3(R,R) - 1 : NEXT R

325 FOR R=1 TO N: FOR C=1 TO N:B3(R,C)=-1^B3(R,C):

NEXT C: NEXT R

326 FOR R=1 TO N:FOR C=1 TO N:B3(R,C)=B3(R,C)^XOLD(C):

NEXT C: NEXT R

327 FOR R=1 TO N:FOR C=1 TO N:CP(R)=CP(R)+B3(R,C)^CC(C):

NEXT C: NEXT R.

328 AA=0:F0R C=1 TO N : AA = AA + CP(C)#CP(C) : NEXT C

329 AA = SQR(AA) : FOR C=1 TO N : CP(C) = CP(C) /AA :

NEXT C

330 AA = SQR(N#(N-1)) / ALPHA

331 FOR CHITON : XNEW(C) « (AO(C) - CP(C) /AA)*XOLD(C) :

NEXT C

332 AA=0:FORC=1TON : AA = AA + XNEW(C) : NEXT C

333 FOR C*1 TON : XNEW(C) =XNEW(C)/AA : NEXT C

334 VNEW=0: FOR C«1 TO N: VNEW=VNEW+CC(C)*XNEW(C) :NEXT C

335 •

336 ' FAILURE DETECTION routine based on equation (6) ...

337*

338 * You may wish to put this routine into KAREX1 and

KAREX2 to

339 * observe the values appearing in (6) during the solutions

340 * of EXAMPLES land 2.

341 '

342 AA = 0

343 FOR C = 1 TO N

344 IF XNEW(C) > 0 THEN A A = AA + L0G(XNEW(C))

345 NEXT C

346 PRINT , LOG(VNEW/V), LOG(N) + AA/N - ITERATION/ (8#N)

347 *

348 IFLOG(VNEW/V) > LOG(N) + AA/N - ITERATION/(8#N)

THEN 400

349 '

350 WEND

351 '

98 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

400 PRINT : PRINT "Failure condition has occurred." :

PRINT

401 PRINT USING "###"; ITERATION; :

FOR C=1 TO N:PRINT USING ”###.####";XNEV(C); : NEXT C : PRINT USING "####. #######"; VNEW/V

402 •

403 PRINT:FOR C=1 TO N-2:PRINT XNEW(C)/XNEW(N), :

NEXT C: PRINT

404 '

405 END

BAM.PAS From "Constructing an Associative Memory" by Bart Kosco, BYTE, September 1987.

program bam;

{ for further information

Rod Taber General Dynamics

Electronics Division Mail Zone 7202-K Box 85310

San Diego, CA 92138

Mail without the Mail Zone takes 3 months.}

{$R+,V+,K+,C-,U-}

Table captionconst

maxrows

* 12;

maxcolumns

= 12;

maxentries

* 144

maxpatterns

= 4;

screenrows

= 24;

screencolumns

= 80;

type threeD * twoD * oneD = square = Textin = var

array[0..maxpatterns,l..1,1..maxentries] of integer;

array[1..maxentries] of integer;

array[l..maxentries] of integer;

array[1..maxentries,l..maxentries] of integer;

string[15];

Ham:array[1..maxpatterns] of integer;

Bipolar_A,BipolarJB,Pattern_A,Pattern_B

OriginalTestPattern,OutPatt

TestPattern, /UCheck,B_Check

Rows_A,Rows_B,Columns_A,Columns_B

MinHam,Num_Patterns,Length_A,Length^B

Memory

topline,bottomline,margin,leftone,rightone le fttwo,le ftthree,righttwo,rightthree,le ftfour energy

threshold,pattern_number,TL,LL,AR,AC,PAC,PAR

test_type,Matrix^Used

Synchmode,input,input_a,input.b

inputfile,outfle

filename,filename2

:threeD; :oneD;

:oneD;

:integer;

:integer;

:square; .•integer;

:integer; :real;

:integer;

:char;

:boolean; :text;

:string[10];

{$1 xface. inc}

function max (x,y: integer): integer; J

begin

if x > y then max : = x else max :■ y;

end;

{ ##*####*####################*######################################################### j

functionmin(x,y: integer): integer;

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 99

begin

if x< y then min := x else min : = y;

end;

{ a#################*###########*#######################################################

{ a#**##*****##*#*##*###*#***##*##**##*#**###**##****#*********##*#***#*#*****#*##**##*#

procedure zero_test; var

index:integer; begin

for index : = 1 to maxentries do

TestPattern[index] := 0; { zero out Test matrix }

end;

{ a##*################################################*###########*#####################

{ a############*#####################*##########**#*###################*##*#############

Procedure Reader (var charValue,errorCode:integer);

{Read the screen at cursor position} type

RegPack = record

AL,AH,BL,BH,CL,CH,DL,DH : Byte;

BP,SI,DI,DS,ES,Flags : Integer;

end; var

Regs : RegPack;

begin

with Regs do

begin

Errorcode:=0; {assume no error}

AH: =$8; BH:=$0; {code 8-screen read, page 0}

Intr($10,Regs); {get character in AL via int 10h} charValue: = AL; {used to be AL - 48 !!!!!} end;

end; {Reader}

{ a#################*#########*##***###########################################**#######

{ a###############################*################**#*####*########**################*#

procedure Read_Rov_and_Column_Values;

var

x:integer; begin repeat

textbackground(lightcyan);

clrscr; { clears out any predefined user background }

textmode(C80); textbackground(lightcyan); textcolor(red);

GoToXY(8,4);

write('B IDIRECTIONAL ASSOCIATIVE MEMORY');

GoToXY(8,7); Textcolor(blue);

write(' Enter the number of patterns to store. < 1..', maxpatterns,' > ');

readln(num_patterns);

GoToXY(8,8);

write (' Enter the number of rows in pattern A: < 1..', maxrows,' > ');

readln(rows_a);

GoToXY(8,9);

write( 'Enter the number of columns in pattern A: < 1..' ,maxcolumns,' > '); readln(columns_a);

GoToXY(8,10);

write(' Enter the number of rows in pattern B: < 1..', maxrows,' > ');

readln(rows_b);

GoToXY(8,ll);

write('Enter the number of columns in pattern B: < 1..' ,maxcolumns,' > '); readln(columns_b);

GoToXY(8,12);

writeln( 'Enter the threshold of neuron activation:');

GoToXY(10,13);

write(' Value must be in range: - ', maxentriesmaxentries,' '); readln(threshold);

Length^A : = Rows_A * Columns_A;

LengtluB :■ RowsJ3 * columns_B;

100 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

TextColor(Red + Blink); { blinks if inputs are unacceptable }

if Length_A <= maxentries then input_a : = True else begin

input_a := False;

GoToXY(l3,17);

writeln(' Values for matrix A are out of bounds.'); repeat until keypressed; end;

if Length_B <= maxentries then input_b := True else begin

input_b : = False;

GoToXY(l3,17);

writeln( ’ Values for matrix B are out of bounds.'); repeat until keypressed; end;

if num_patterns < min(length_a,length_b) then input : = True else begin

input : = False;

GoToXY(13,17);

writelnC Number of patterns must be less than ' ,min(length_a,length_b)); repeat until keypressed; end;

TextColor(Blue);

until (input_a and input_b and input); { all inputs are within range } end;

{ ********####****X##**####****X##**###*#***********####***###*******************####*** }

{ ************************************************************************************** } procedure UseCurrentScreenSetup;

begin

Synchmode

:= Tr

topline

5;

bottomline

s 15;

margin

= 3;

leftone

* 4;

rightone

= 18

lefttwo

= 22

righttwo

= 36

leftthree

= 40

rightthree

= 54

leftfour

i;

= 58

{ ************************************************************************************** }

{ ************************************************************************************** } procedure SetMemoryToZero;

{$R+,V+,K+,C-,U-}

var

index,row,column,size:integer; begin

size := max(length_a,length_b); for row :■ 1 to size do for column : * 1 to size do memory [row, column] :=0;

end;

{ ************************************************************************************** }

{ ************************************************************************************** )

Procedure SaveScreen(Matrix_Used:char;row_in,column.in:integer);

var

position,charValue,ErrorCode :integer;

begin

position ;«1;

for AR : = 1 to row__in do begin

for AC : ■ 1 to columa_in do begin

PAC:«LL+AC-1;

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 101

PAR:=TL+AR-1;

GoToXY(PAC,PAR);

Readcr(charValue,ErrorCode); Delay(2); if ErrorCode <> 0 then write('error');

case Matrix-Used of 'A': begin

if charValue = 177 then Pattern_A[Pattern_Number,l,position] := 1 else

Pattern. A [Pattern__Number,l,position] := 0; end;

' B': begin

if charValue = 177 then PatterruB[Pattern__Number,l,position] := 1 else

PatternJB[Pattera_Number,l,position] := 0; end;

•T': begin

if charValue = 177 then TestPattem[position] :*1 else

TestPattem[position] :=0; end;

end; { end case }

position :* position + 1; end;

end;

{ the following text erases the instructions yet leaves the Test Pattern }

if Matrix_Used = 'T' then

begin

TextBackground(lightcyan);

GoToXY(l,BottomLine + 4); { Beginning of instructions on screen } writelnO ');

writeln(' ');

writeln(' ');

writeln(' ');

end;

end;

{ tttf******tt*****Otf**M*tt*tt*tt****«**ff*KXtfft***«*****fftttttt*tfft******tttt**tf***ft«tf *************

{ **************************************************************************************

Procedure DataFromKeyboard (Matrix.Used:char; rows,columns: integer);

{PatternNumber must be defined prior to call}

var

char3 :char;

intval : integer;

charValue : integer;

label

loopl,InitLoop;

begin

TextBackground(lightgray);

GoToXY(l,l);

{ only print heading for the first time this screen appears i.e., Matrix_a } if Matrix_Used <> 'B' then case PatterruNumber of 0: begin

write (' Enter the Test Pattern'); end;

1..MaxPatterns: begin

TextColor(blue);

write(' Enter Pattern Number ' ,pattern_iJumber:2 ); end;

end; {case}

TextColor(blue);

TextBackground(lightcyan);

102 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

case Matrix^Used of

'A' : begin { Matrix A input }

GoToXY(LL,TL-2); write('MATRIX A’); end;

*8* : begin { Matrix B input }

GoToXY(le fttwo, TL - 2); write(•MATRIXB')i end;

'T' : begin { TestPattem input}

GoToXY(LL,TL - 2); write('TEST PATTERN'); end;

end; { end case }

TextColor(Magenta);

TextBackground(lightgray);

for AR: = 1 to Rows do begin

for AC: = 1 to Columns do begin

PAC: =LL+AC-1; {column to place cursor}

PAR: =TL+AR-1; {row to place cursor}

GoToXY(PAC,PAR); write(chr(249));

GoToXY (PAC, PAR); { cursor stays in position }

end; end;

{A zero matrix is now on the screen for Pattern ' PatternNumber'}

TextColor(blue); { INSTRUCTIONS}

TextBackground(lightcyan);

GoToXY(l,BottomLine + 4); { Next free line on screen }

writeln( 1 Position cursor using arrow keys.');

writeln( * Press period "." to change pattern.');

writeln(' Press space bar to remove changes. *);

write(* Press RETURN to store Matrix after entering complete pattern 1 );

Textbackground(lightgray);

InitLoop: GoToXY(LL,TL); { cursor to first element of input pattern} AC:=LL; {initialize row and column counters}

AR:=TL;

loopl:read(kbd,char3);

intval:=ord(char3); if intval = 27 then begin

read(kbd,char3); intval:«ord(char3); end;

case intval of { beeps on attempt to move off pattern display }

80: begin

if AR + 1 >- Rows + TL then begin sound(800); delay(60); nosound; end else AR :■ AR+1; { down arrow} end;

72: begin

if AR - 1 < TL then

begin sound(800); delay(60); nosound; end else AR :« AR-1; {up arrow} end;

75: begin

if AC-1< LL then

begin sound(800); delay(60); nosound; end else AC AC-1; {left arrow} end;

77: begin

if AC + 1 >= Columns + LL then begin sound(800); delay(60); nosound; end else AC : = AC+1; {right arrow} end;

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 103

46: begin {digits}

write(chr(177)); end;

32: begin

textcolor(magenta); write(chr(249)); textcolor(blue); end;

13: begin

SaveScreen(Matrix_Used,Rows,Columns); { works for Matrix A, B or Test } end; {of case 13}

end; {case statement}

GoToXY(AC, AR); {goto new cursor position} if intval <> 13 then goto loopl;

TextBackground(lightcyan); end; {DataFromKeyboard}

{ ************************************************************************************** }

{ ************************************************************************************** }

procedure EraseOldMatrices;

begin

TextBackground(lightcyan);

{ clear old Matrix A }

LL := leftone;

for AR:= 1 to Rows_A do

begin

for AC: = 1 to Columns_A do begin

PAC:=LL+AC-1; {column to place cursor}

PAR: =TL+AR-1; {row to place cursor}

GoToXY(PAC,PAR); write(' '); end; end;

{ clear old Matrix B }

LL := left two;

for AR: = 1 to Rows_B do

begin

for AC: ■ 1 to Columns_B do begin

PAC:=LL+AC-1; {column to place cursor}

PAR: =TL+AR-1; {row to place cursor}

GoToXY(PAC,PAR); write(' '); end; end;

end;

{ ************************************************************************************** }

{ ************************************************************************************** }

Procedure InputTestPattem;

var

n:integer; begin

Pattern_Number :* 0;

for n : = 1 to maxentries do begin

/L.Check[n] :=0;

B_Check[n] :»0; end;

TextColor(Red); repeat

GoToXY(l,Bottomline + 2);

writelnO ’) writeln(* ’) writeln(' ’) writeln(' *)

104 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

GoToXY(l,Bottomline + 2);

write( • Is test pattern of type A or B ? (A/B) *);

readln(test_type); until test_type in [ 'a', 'A', »b’,'B* ];

GoToXY( 1,Bottomline + 2); { erases 1 Is test pattern of' query }

writeln ( 1 »).

{ eliminate lowercase input and relace with uppercase equivalent} iftest_type* 'a' then test_type := 'A r ; if test_type * • b 1 then test_type 'B f ;

if test_type= • A * then begin clrscr;

TL: stopline; LL:«leftone;

DataFromKeyboard(•T',rows_a,columns_a); end else

begin { if test_type = B } clrscr;

TL :* topline; LL :* leftone;

DataFromKeyboard(•T 1 ,rows_b,columns_b); end;

OriginalTestPattern := TestPattern; end;

{ XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX#XXXXXXXXXXXXXXXX#XXXXXXXXXXXXXXX#XX#XX#XX#X }

{ XXXXXX#XXXXXXXXXX#XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX#XXXXXXXXXXXXXXXX#XXXXXXXXX#XXX } procedure ComputeEnergy;

var

sum : real; temp: oneD;

pattern_n,len_A,len_B,tempi: integer;

begin sum := 0.0; energy := 0.0;

for pattern_n : = 1 to num_patterns do begin

for len_B :=lto Length_B do begin

temp[len_B] :» 0; for len_A : = 1 to Length_A do begin

tempi :s ( memory[len_A,len_B] - 0 );

temp[len_B] := temp[len_B] Pattern_A[pattern_n,l,lea_A] * tempi; end; end;

for len_B : = 1 to Length_B do

sum :s sum + temp[leruB] # Pattern_B[pattern_n,l,len_B]; energy := -sum; end; end;

{ MKXNKXKKKMKXKXXKXKKXKNKXXKKNNXXNNKMNNMNNHMNMIOnHtKXXXNXXNNMXKMMKlHIKKMXiHnntKXttttKfHHtttllKtftt }

{ XXXXXKXXXXXXXXXXXXXXXXXXXXXXXXXKXXKXMMNKKXXXXKXXXXXXXKXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX } procedure Hamming;

var

n,J: integer; begin

for n : * l to num_patterns do Ham[n] 0;

MinHam := 1;

for n :* 1 to num_patterns do begin

if test_type = 'A' then begin

for J : s l to Length_A do if Pattern_A[n,lJ] <> 0riginalTestPattern[J] thenHam[n] :»Ham[n]+l; if Ham[n] < Ham[MinHam] then MinHam :■ n;

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 105

end

else

begin

for J : = 1 to LengthJB do

if Pattern_B[n,l,J] <> OriginalTestPattern[j] thenHam[n] :=Ham[n] + l; if Ham[n] < Ham[MinHam] then MinHam : = n; end; end; end;

{ ************************************************************************************** procedure status(x,y:integer;TxT:textin);

var first:char; last :textin;

begin

TextBackground(blue); { if status is not called from StatusLine }

first := copy(TxT,l,l);

last :* copy(TxT,2,(length(TxT) - 1));

GoToXY(x,y); Textcolor(white); write(first);

GoToXY(x+l,y); Textcolor(yellow); write(last);

end;

{ **************************************************************************************

{ ************************************************************************************** Procedure StatusLine;

var i:integer; chrchar;

begin

TextBackground(blue);

GoToXY(1,23);

for i : = 1 to screencolumns do write(' '); { status line background }

GoToXY(12,23); TextColor(Yellow);

write(’STATUS LINE - First letter of choice and RETURN selects:');

GoToXY(1,24);

for i : = 1 to screencolumns do write(' '); { status line background }

Status(15,24,’Quit');

if SynchMode = True then Status(34,24, 'Synch ') else Status(34,24,'Asynch');

Status(55,24, 'Ham dist');

GoToXY(15,20);

write('Select execution Mode — Synchronous/Asynchronous'); repeat begin

read(kbd,ch);

if ch in ['s', 'S'] then SynchMode := True; if ch in [ 'a',' A' ] then SynchMode :« False; end;

until ch in ['a','A','s','S']; if SynchMode = True then Status(34,24, 'Synch ') else Status(34,24,'Asynch');

Textbackground(lightcyan);Textcolor(blue);

GoToXY(15,20);

write(' ');

end;{StatusLine}

{ **************************************************************************************

{ ************************************************************************************** Procedure TurnPCcursorOff;

{get rid of regular cursor} type

RegPack = record

AL,AH,BL,BH,CL,CH,DL,DH : Byte;

BP,SI,DI,DS,ES,Flags : Integer; end; var

Regs : RegPack;

106 BYTFi LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

begin

with Regs do

begin

AH: =$1; CH:=16;CL:= 0;

Intr($10,Regs); end;

end;{TurnPCcursorOff}

{ iHHHHHHMHHHHHHHHHMHMtttIHHHMHHMHHHtIHHHHHHHHttHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHj ]

Procedure TurnPCcursorOn;

{turnon regular cursor} type

RegPack = record

AL,AH,BL,BH,CL,CH,DL,DH : Byte;

BP,SI,DI,DS,ES,Flags : Integer; end; var

Regs : RegPack;

begin

with Regs do

begin

AH:=$1; CH: =7;CL: *» 9; {start line>end means cursor off}

Intr($10,Regs); end;

end; {TurnPCcursorOn}

{ **##*##**######*##*######«***#* KM* |

procedure BipolarizeB; ;

var

index:integer; begin

for index : = 1 to Length_B do begin

if Pattern_B[Pattern_Number,1,index] ■ 0 then BipolarJ3[Pattern_Number,1,index] : * -l else BipolarJ3[Pattern_Numbcr,1,index] : = 1;

end;

end;

{ a******####*#####*######*###*#*******a k*xx»*xxkxx##xxx#x#######x#xx########## # ## m ## m ^ ]

procedure BipolarizeA; ;

var

index:integer; begin

for index : = 1 to LengtluA do begin

if Pattern_A[Pattern_Number,l,index] ■ 0 then Bipolar_A[Pattern_Number # l # index] :■ -1 else Bipolar_A[Pattern__Number,l, index] :■ 1;

end;

end;

{ IHHHHHHHHHHMHMMMHiXMXJHHHHHHHHHHHHHtaaJtaiUHHMHHHHHHHHHHHHHHHHHHHHHHHHHMHHHHHHHHHHHHHHHMHt }

procedure Memorize_Bipolar; ;

var

patterns, leruA,len_B, temp : integer; begin

GoToXY(4,bottomline + 2 ) ;

write(' # Please wait - Bipolarization in Progress * •); for pattern_n : = 1 to num_patterns do for len__A : ■ 1 to Length_A do for len_B : = 1 to LengthJB do memory[len_a,len_b] := memory [ len_a , len_b] +

bipolar_a[pattern_n,l,len_a] * bipolar__b[pattern_n,l,len_b];

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 107

end;

{ *##*##**##*###**###**###***####*0##*#####**#*#**#*#******##*#***#*#************#***** }

{ ***##**####*##*#**#*o##**##o*o##*###*##*##***##*####*####**##**#*#**#**####*##***** }

function ChecklfKeypressed: boolean;

var

ch:char; n,keyint: integer; begin

if not(keypressed) then ChecklfKeypressed := False else begin

read(kbd,ch); keylnt := ord(ch); case keyint of

113,81 : ChecklfKeypressed :=True;

{ Q or q for Quit has been pressed }

115,83 : begin (Sors)

Synchmode := True;

Status(34,24,'Synch ');

ChecklfKeypressed := False; {continues execution} end;

97,65 : begin {A or a}

Synchmode : = False;

Status(34,24,'Asynch');

ChecklfKeypressed := False; {continues execution} end;

104,72 : begin

for n : = 1 to num_patterns do begin

GoToXY(l6,18+(n-1));

write('Hamming Distance for Pattern ' ,test_type); writeln('',n,' is :',Ham[n]); end;

GoToXY(20,22);

writeln( 'Press any key to continue '); repeat until keypressed;

GoToXY(20,22);

writeln( 1 ');

ChecklfKeypressed :* False; {continues execution} for n : = 1 to num_patterns do begin

GoToXY(l6,18+ (n-1)); write(' ');

writeln(' ');

end;

end;

else ChecklfKeypressed := False;

{ no action taken }

end; { end case } end;

end;

{ *############*#####*#########*###»########################*########»######*####*###### }

Procedure Bammer(Test_Pat:oneD; test_now:char;

lengl,leng2:integer);

var

Memory_Transpose :Square;

maxrow,n,k,i,J,m,y,Start,Finish :integer; BinVect :0neD;

begin

Textbackground(lightcyan);

TextColor(blue);

GoToXY(lefttwo,TL - 2); write('MATRIX A');

G 0 T 0 XY(leftthree,TL - 2); write('MATRIX B');

108 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

Textbackground(1ightgray);

TextColor(magenta);

if Synchmode = True then

begin { Synchronous Mode prints out all Neurons }

for j :» 1 to lengl do OutPatt[J] := 0;

case test_now of 'A' : begin

B_Check :* Test_Pat;

for i : = 1 to leng2 do if Test_Pat[i] * 0 then BinVect[i] :=-l else BinVect[i] := 1;

for i :» 1 to lengl do for J : = 1 to leng2 do Memory_Transpose[J,i] :- Memory[i,J];

for J : = 1 to lengl do for i : = 1 to leng2 do

0utPatt[J] :*0utPatt[J] + BinVect[i] # Memory_Transpose[i,J];

end;

•B' : begin

A^Check : = Test_Pat;

for i : = 1 to leng2 do if Test_Pat[i] « 0 then BinVect[i] :=-l else BinVect[i] := 1;

for i : = 1 to lengl do for j : * 1 to leng2 do

0utPatt[i] := 0utPatt[l]+ BinVect[j] #Memory[j,i];

end;

end; { end case }

for J : * 1 to lengl do begin

if (0utPatt[j] - threshold) > 0 then TestPattern[J ] := 1 else

if (OutPatt[J] - threshold) < 0 then TostPattern[j] 0 else

case test_now of

'A' : TestPattern[J] :=/L.ChecklJ];

'B' : TestPattern[J] := B_CheckfJ]; end; { end case } end; { end for Start to Finish }

case test_now of •A':

begin

k:«TL-l; { prints out matrix A )

for y : ■ 0 to LengtluA - 1 do

begin

i : = y mod Columns_A; if i ■ 0 then k : = k + l;

GoToXY(lefttwo + i,k);

if TestPattern[y + 1] ■ 1 then write(ohr(177)) else write(chr(249));

end;

k:»TL-l; { prints out matrix B }

for y : = 0 to Length_B - 1 do

begin

i : = y mod Columns_B; if i = 0 then k :*k + l;

GoToXY(leftthree + i,k); if Test_Pat[y+ 1] a l then writo(chr( 177)) else write(chr(249));

end;

end; { 'A' )

•B*: begin

continued

BYTE LISTINGS SUPPLEMENT

JULY-SEPTEMBER, 1987 109

k : = 1; { prints out matrix A }

for i : = 0 to Rows_A - 1 do

begin

for j : = 0 to Columns_A -1 do begin

GoToXY(lefttwo + j,TL +i); if Test_Pat[k] = 1 then write(chr( 177)) else write(chr(249));

k := k +1; end; end;

k : = 1; { prints out matrix B }

for i : = 0 to Rows_B - 1 do

begin

for j : = 0 to Columns_B - 1 do begin

GoToXY(leftthree + j,TL + i); if TestPattern[k] = 1 then write(chr(177)) else write(chr(249));

k := k + 1; end; end;

end; { »B' }

end; { case test_now of } end; { if Synchmode true }

if Synchmode = False then

begin { Asynchronous Mode prints out one Neuron }

for j : = 1 to lengl do OutPatt[j] :* 0;

Case test_now of 'A' : begin

B_Check :=Test_Pat;

for i : = 1 to leng2 do if Test_Pat[i] = 0 then BinVect[i] : = -l else BinVect[i] := 1;

for i : = 1 to lengl do for j : = 1 to leng2 do Memory_Transpose[J,i] := Memory[i,j];

Start := Random(lengl); if Start = 0 then Start : = lengl;

for i : = 1 to leng2 do OutPatt[Start] := OutPatt[Start] +

BinVect[i] * Memory_Transpose[i,Start];

end;

*B' : begin

/LCheck : = Test_Pat;

for i : = 1 to leng2 do if Test_Pat[i] ■ 0 then BinVect[i] :*-l else BinVect[i] : = 1;

Start : = Random(lengl); if Start = 0 then Start : = lengl;

end;

for i : ■ 1 to leng2 do OutPatt[Start] : = OutPatt[Start] +

BinVect[i] * Memory[i,Start];

end;

{ end case }

for J : ■ 1 to lengl do begin

if (OutPatt[J ] - threshold) > 0 then TestPattern[J ] : * 1 else

if (OutPatt[J] - threshold) < 0 then TestPattern[J] :■ 0 else

110 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

case test_nov of

'A' : TestPattern[J] := A_Check[J];

'B' : TestPattern[J] :=B_Check[J]; end; { end case } end; { end for Start to Finish }

case test_now of 'A 1 : begin

k:=TL-l; { prints out matrix A }

for y : • 0 to Length_A - 1 do

begin

1 : s y mod Columns_A; if i = 0 then k := k + 1;

GoToXY(lefttwo + i, k);

if TestPattern[y + 1] = 1 then vrite(chr(177)) v else write(chr(249));

end;

k : = TL - 1; { prints out matrix B } for y : = 0 to Length_B - 1 do begin

i : = y mod Columns_B; if i * 0 then k :»k + l;

GoToXY(leftthree + i, k); if Test_Pat[y + 1] - 1 then write(chr(177)) else write(chr(249));

end;

end; { 'A r }

'B' : begin

k : 3 ^ { prints out matrix A }

for i : = 0 to Rows_A - 1 do

begin

for j : = 0 to Columns_A - 1 do begin

GoToXY(lefttwo + J,TL+ 1); if Test_Pat[k] - 1 then write(chr(177)) else vrite(chr(249));

k := k + 1; end; end;

{ prints out matrix B }

for i : = 0 to Rows_B - 1 do begin

for J : = 0 to Columns_B - 1 do begin

GoToXY(leftthree + J,TL+i); if TestPattern[k] - 1 then write(chr(l77)) else write(chr(249));

k := k +1; end;

end;

end; { »B' }

end; { case test_now of } end; { end if Synchmode False }

GoToXY(l,Bottomline + 2);

TextBackground(lightcyan);

TextColor(blue);

end;

{ .. J

{ . . . »

procedure Bam; ;

begin

GoToXY(1,1); TextColor(Red);

v,rlte (' PROCESSING');

if test_type *'A'then •

begin repeat

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 111

Bammer(TestPattern,' B', Leng thJB, Lengths);

Bammer(TestPattern,’A',Length_A,Length_B); until ChecklfKeypressed; end else begin repeat

Bammer(TestPattern,'A',Length_A,Length_B);

Bammer(TestPattern,'B',Length_B,Length_A); until ChecklfKeypressed; end;

end;

{ XXXXXXX##XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX#XXXXXX#XXXX*XXXXX#XX#XXXXX#X

function DataFromFile:boolean; begin

textbackground(lightcyan);

clrscr; { clears out any predefined user background }

textmode(C80); textbackground(lightcyan); textcolor(red);

GoToXY(8,4);

write('B I D I R E C T I 0 N A L ASSOCIATIVE MEMORY’);

DataFromFile :* False;

GoToXY(l,8);

if yes(' Do you want to read the patterns from a file ? ') then

begin

GoToXY(l,9);

write(’ Enter the filename to read from: ’);

readln(filename);

assign(inputfile,filename);

{*i-}

reset(inputfile);

{$i+}

DataFromFile :«True; if not(ioresult = 0) then begin

GoToXY(l,9); Textcolor(Red + Blink); writeln( ’Unable to open file '); exit; end; end; end;

{ xxxxxxxxxxxxxxxxx#xxxxxxxxxxxxxxxxxxxxx#x#xxxxxxxxxx#xxxxxxxxxx#xxxxxxx#x#xxxxxxxxx#xx

procedure ReadlnFile; var

temp:integer; ch:char; begin

TurnPCcursorOff; readln(inputfile,num_patterns); readln(inputfile,Rows_A); readln(inputfile,Columns_A); readln(inputflie,Rows_B); readln(inputfile,Columns_B);

Length_A := Rows_A * Columns_A;

Length^B :* Rows_B * columns_B; clrscr;

textcolor(blue); TL := topline;

GoToXY(l,l);

write( 'Reading Patterns from file: ',filename);

GoToXY(leftone,TL - 2) ; write('MATRIX A');

GoToXY(le fttwo,TL - 2); write('MATRIXB'); textbackground(lightgray);

textcolor(magenta); ,

for Pattern_Number :» 1 to num_patterns do

begin

GoToXY(13 , bottomline+1); write('Pattern ' ,Pattern_Number);

112 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

TL : = topline; LL : = leftone;

for AR :* 1 to Rows_A do begin

for AC : = 1 to Columns_A do begin

PAC := LL + AC - 1;

PAR TL + AR - 1;

GoToXY(PAC,PAR); read(inputfile,temp); if temp = 1 then write(chr( 177)) else write(chr(249));

end;

end;

LL := lefttwo; TL := topline; for AR : = 1 to Rows_B do begin

for AC : = 1 to Columns_B do begin

PAC := LL + AC - 1;

PAR : = TL + AR - 1;

GoToXY(PAC,PAR); read(inputfile,temp); if temp = 1 then write(chr(l77)) else write(chr(249));

end;

end;

LL :* leftone; TL := topline;

SaveSoreen('A',Rovs_A,Columns_A)j LL := lefttwoj TL := topline j SaveScreen('B*,Rovs_B,Columns_B);

BipolarizeB;

BipolarizeA;

GoToXY(8,bottomline + 2); Textbackground(lightcyan);

Textcolor(red); write( 'Press any key to continue reading patterns.'): repeat until keypressed; read(kbd,ch);

GoToXY(8,bottomline + 2); Textbackground(lightcyan); write ( * *); { erase above }

Textcolor(magenta); Textbackground(lightgray);

end; { for PatterruNumber }

textcolor(blue); Textbackground(lightcyan);

GoToXY(4, bottomline + 1); TurnPCcursorOn;

writeln( 'Enter the threshold of neuron activation;');

GoToXY(4,bottomline + 2);

write('Value must be in range; - »,maxentries,', + »,maxentries,' »); readln(threshold); TurnPCcursorOff;

GoToXY(4, bottomline + 1); writeln(' •).

end;

Procedure WriteToFile; ;

var n,z;integer;

begin

if yes(' Do you want to save the memory patterns to a file ? •) then begin

write( 1 Enter the filename to save patterns to: 1 ); readln(filename2); assign(outfle,filename 2 ); rewrite(outfle); writeln(outfie,num_patterns); writeln(outfle,Rows_A); writeln(outfle,Columns_A); writeln(outfle,Rows_B); writeln(outfle,Columns_B); for n : * 1 to num_patterns do begin

for z : ■ 1 to Length_A do write(outfle,Pattern_A[n,l,z],• •); writeln(outfle);

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 113

for z : = 1 to LengthJB do write(outfle,Pattern_B[n,l,z],' '); writeln(outfle); end;

close(outfle);

end;

end;

{ a#################*##*###############*#############################*###########*###### }

{ a##**#***#########*##*###*****#***##*****#**#*#**#*###*##*#**#####*##**#*#*#********** }

begin { MAIN }

repeat { until not ’yes try another set of patterns ' }

UseCurrentScreenSetup; if DataFromFile = False then begin { input is from the keyboard }

Read_Row_and_Column_Values;

SetMemoryToZero;

clrscr;

for Pattern_Number :« 1 to num_patterns do begin

TL:= topline; LL:=leftone;

DataFromKeyboard(' A',rows_a,columns_a);

TL :« topline; LL := left two;

DataFromKeyboard('B',rows_b,columns_b);

BipolarizeB;

BipolarizeA;

if Pattern_Number <> num_patteros then EraseOldMatrices; end;

end { input is from the keyboard } else { input is from the files }

ReadlnFile;

SetMemoryToZero;

Memorize_Bipolar;

ComputeEnergy;

TuraPCcursorOn;

repeat { until not yes 'another test pattern ' } zero_test;

InputTes tPattem;

Hamming;

TumPCcursorOff;

StatusLine;

Bam;

TuraPCcursorOn;

WriteToFile;

until not yes(' Do you want to try another test pattern ? '); until not yes(' Do you want to try another set of patterns ? ');

TextMode; { returns screen to previous graphics color mode }

clrscr;

end.

XFACE. INC From "Constructing an Associative Memory" by Bart Kosco, BYTE, September 1987.

type

mstring = string[100]; var

outfile : text;

FUNCTION yes(PROMPT:MSTRING): BOOLEAN; var

ch : string[2]; begin

(#$I-#)(*$R-#)

repeat

write(prompt,' (y/n) '); readln(ch);

until (ch ='y') or (ch • 'Y') or (ch »'N') or (ch «'n') and (ioresult=0); (»$I+#)(#$R-f») yes :■ (ch »• y') or (ch «'Y'); end;

114 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

PROCEDURE setoutfile; var

ch: char; begin

(*$I-*)(*$R-*)

repeat

write('OUTPUTDESTINATION: P(rinterC(onsole : readln(ch);

until (eh inCcVCVpVP']) and (ioresult = 0); case ch of

'pVP' : ASSIGN(outfile, 'LST:');

'cVC' : ASSIGN(outfile, 'CON:'); end; (#case#)

REWRITE(OUTFILE);

(*$I+*)(*$R+#) end; (*setoutfile#)

FUNCTION getnum(PROMPT:MSTRING; LOW,HIGH: INTEGER): INTEGER; var

val : integer; begin

VAL .*=-31695;

(*$I-*)(*$R-*)

repeat

write(prompt,' (',low,'..»,high,'): •); readln(val);

if (val < low) or (val > high) then writeln(' VALUE OUT OF RANGE '); if ioresult <> 0

then writeln( 'WRONG DATA TYPE '); until (val >= low) and (val <= high) and (ioresult = 0); getnum := val;

(#$I+#)(*$R+*)

end;

FUNCTION getchar(PROMPT:MSTRING) :CHAR; var

ch : char; begin

(*$I-*)(#$R-»)

repeat

write(prompt); readln(ch);

until (ch IN ['a>..'z','A'..'Z']) and (ioresult = 0); getchar := ch;

(*$I+*)(»$R+*)

end;

FUNCTION getreal(PROMPT:MSTRING; LOW,HIGH:REAL) :REAL; var

val : real; begin

VAL := -31695.7;

(»$I-*)(»$R-»)

repeat

write(prompt,'(',low:3:l,'.. 1 ,hlgh:3:l,'): '); readln(val);

if (val < low) or (val > high) or (ioresult <> 0) then writeln(' Data incorrect type or out of range '); until (val <= low) and (val <* high) and (ioresult ** 0); getreal :« val;

(#$I+#)(#$R+#)

end;

con tinned

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 1 IS

BAM.BAS From "Constructing an Associative Memory" by Bart Kosco, BYTE, September 1987.

1000 CLS 1010 PRINT 1020 PRINT 1030 PRINT 1040 PRINT "

1050 PRINT "

1060 PRINT "

1070 PRINT "

1080 PRINT "

1090 PRINT "

1100 PRINT "

1110 PRINT "

1120 PRINT "

1130 PRINT "

1140 PRINT "

1150 PRINT "

1160 PRINT 1170 PRINT 1180 PRINT 1190 PRINT 1200 PRINT "

1210 S$=INKEY$

1220 IF LEN(S$) =0 THEN GOTO 1210

1230 IF S$<>"Y" AND S$<>"y" THEN GOTO 1760

1240 CLS

1250 PRINT

1260 PRINT " USING THE BAM DEMONSTRATION PROGRAM"

1270 PRINT

1280 PRINT " - CHANGE NETWORK PARAMETERS to set new values of the A and B"

1290 PRINT " dimensions, the number of cells updated per iteration of the" 1300 PRINT " network, and the percentage of elements to change state when" 1310 PRINT " random noise is added to the A and B fields. The maximun"

1320 PRINT " size of the A or B fields is 144 elements (12x12)."

1330 PRINT

1340 PRINT " - CLEAR NETWORK fills the matrix M with 0. All stored patterns" 1350 PRINT " will be lost when this command is executed, so be sure to"

1360 PRINT " save the M matrix before executing this command."

1370 PRINT

1380 PRINT " - LOAD MEMORY MATRIX M displays all current BAM interconnect" 1390 PRINT " matrix files stored on disk. Enter the desired filename"

1400 PRINT " to load that file into the M matrix."

1410 PRINT

1420 PRINT " - SAVE MEMORY MATRIX M to store the current M matrix to a disk" 1430 PRINT " file. The dimensions of the A and B fields are also saved."

1440 PRINT 1450 PRINT

1460 PRINT " PRESS ANY KEY TO CONTINUE"

1470 S$=INKEY$

1480 IF LEN(S$)*0 THEN GOTO 1470 1490 CLS 1500 PRINT

1510 PRINT " - EDIT/RUN NETWORK to input new patterns to the A and B fields." 1520 PRINT " Once input, the network can either learn the new pattern or" 1530 PRINT " execute one or more iterations of the network.

1540 PRINT

1550 PRINT " - LEARN CURRENT PATTERN takes the current state of the A and B" 1560 PRINT " fields and changes the M matrix to learn this pattern. The"

1570 PRINT " cursor will disappear until this operation is complete.

1580 PRINT

1590 PRINT " - ADD RANDOM NOISE will flip the state of a certain percentage" 1600 PRINT " of elements in both the A and B fields. The percentage is"

1610 PRINT " set in the NETWORK PARAMETERS. This can be used to see how"

1620 PRINT " different a pattern can be to still be recalled.

1630 PRINT

1640 PRINT " - RUN THE NETWORK will execute two complete iterations of the" 1650 PRINT " network when the parameter is set for synchronous operation." 1660 PRINT " When the number of cells updated per iteration Is greater "

1670 PRINT " than 0, 10 iterations of the network are executed. At each"

1680 PRINT " iteration, only the number of cells specified In the parameter" 1690 PRINT " are updated per field."

1700 PRINT 1710 PRINT

X****************************************************************”

* *«

* BIDIRECTIONAL ASSOCIATIVE MEMORY *»

* DEMONSTRAION PROGRAM #"

* *»

* (C) COPYRIGHT 1987 LOGICAL DESIGNS CONSULTING INC. *"

* 3229 ERIE ST. SAN DIEGO, CA 92117 #"

* (619) 276-3955 *"

* *»

* BY DUANE DESIEN0 #"

* x»

**x*x******x*****xx**x**x******xxx*xxx*xxxxxx**xxxxxxx**xxxx*xxx*»

PRESS (Y) FOR INSTRUCTIONS"

PRESS ANY KEY TO CONTINUE"

1720 PRINT "

1730 S$=INKEY$

1740 IF LEN(S$) =0 THEN GOTO 1730 1750 REM

1760 ON ERROR GOTO 4720

1770 DIM A$(144),B$(144),XJC(144),Y!J(144),M$(144,144) 1780 AXSIZE=12: AYSIZE=12: BXSIZE-12: BYSIZE=12 1790 CLS 1800 KEY OFF 1810 PRINT "

1820 PRINT "

1830 PRINT 1840 PRINT 1850 PRINT "

1860 PRINT 1870 PRINT 1880 PRINT 1890 PRINT "

1900 PRINT 1910 PRINT "

1920 PRINT "

1930 PRINT "

1940 PRINT "

1950 PRINT »

1960 PRINT "

1970 PRINT 1980 INPUT "

BIDIRECTIONAL ASSOCIATIVE MEMORY " DEMONSTRATION PROGRAM"

BY DUANE DESIENO"

MAIN MENU"

1 - CHANGE NETWORK PARAMETERS"

2 - CLEAR NETWORK"

3 - LOAD MEMORY MATRIX M"

4 - SAVE MEMORY MATRIX M"

5 - EDIT/RUN NETWORK"

6 - QUIT"

INPUT CHOICE (1-6): CHOICE

1990 ON CHOICE GOSUB 2010,2370,4240,4480,3000,4750 2000 GOTO 1790 ’THIS IS THE MAIN LOOP OF THE PROGRAM 2010 REM IHHHHHHHHUHHHMHMHHHHHHMHHHHHHHHtiHHHHHHHHHHHHHHHHHHHUj 2020 REM CHANGE NETWORK PARAMETERS

2030 REM 2040 CLS 2050 LOCATE 5,1

CURRENT NETWORK PARAMETERS"

1 - A FIELD X DIMENSION

2 - A FIELD Y DIMENSION 3-B FIELD X DIMENSION

4 -B FIELD Y DIMENSION

5 - NUMBER OF CELLS CHANGED PER »

ITERATION ASYNCHRONOUS)

6 - RANDOM NOISE PERCENTAGE

7 - RETURN"

2060 PRINT "

2070 PRINT 2080 PRINT 2090 PRINT "

2100 PRINT "

2110 PRINT "

2120 PRINT "

2130 PRINT "

2140 PRINT "

2150 PRINT "

2160 PRINT "

2170 PRINT

2180 INPUT » ENTER CHOICE :»; CHOICE

2190 IF CH0ICE=7 THEN GOTO 2290 2200 INPUT " ENTER NEW VALUE :"; NVAL

2210 ON CHOICE GOTO 2230,2240,2250,2260,2270,2280 2220 RETURN

2230 AXSIZE=NVAL: GOTO 2010 ' LOOP TILL DONE

2240 AYSIZE=NVAL: GOTO 2010

2250 BXSIZE=NVAL: GOTO 2010

2260 BYSIZE=NVAL: GOTO 2010

2270 ASYN=NVAL: GOTO 2010

2280 NOISE=NVAL: GOTO 2010

2290 IF AXSIZE#AYSIZE>144 THEN PRINT "A FIELD TOO URGE";: GOTO 2050 2300 IF AYSIZE>16 THEN PRINT "A FIELD Y DIM TOO URGE";: GOTO 2050 2310 IF BXSIZE#BYSIZE>144 THEN PRINT "B FIELD TOO LARGE";: GOTO 2050 2320 IF BYSIZE>16 THEN PRINT "B FIELD Y DIM TOO URGE";: GOTO 2050 2330 RETURN ’ END OF CHANGE NETWORK PARAMETERS

2340 REM a#########################################***#######

2350 REM CLEAR NETWORK MATRIX M,A,B

2360 REM

2370 FOR 1=1 TO 144 2380 A*(I)=0

2390 B*(I)=0

2400 NEXT I

2410 FOR 1=1 TO AXSIZE#AYSIZE 'CLEAR THE MEMORY MATRIX M

2420 FOR J=1 TO BXSIZE#BYSIZE

2430 M*(I,J)=0

2440 NEXT J

2450 PRINT".";

: ";AXSIZE : ";AYSIZE : ";BXSIZE : ";BYSIZE

: ";ASYN : ";NOISE

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 117

2460 NEXT I

2470 RETURN ■ END OF CLEAR NETWORK

2480 REM a######*###*###*#**##**######*###*##*

2490 REM DISPLAY A AND B FIELDS

2500 REM a####################################

2510 CLS

2520 LOCATE 1,19: PRINT "A FIELD";

2530 LOCATE 1,59: PRINT "B FIELD";

2540 REM **** DRAW BOX AROUND A FIELD **#*

2550 LOCATE 3,15: PRINT CHR$(218)

2560 FOR 1=1 TO AXSIZE: LOCATE 3,15+1: PRINT CHR$(196);: NEXT I 2570 PRINT CHR$(191);

2580 FOR J=1 TO AYSIZE

2590 LOCATE 3+J, 15: PRINT CHR$(179);

2600 LOCATE 3+J,15+AXSIZE+l: PRINT CHR$(179);

2610 NEXT J

2620 LOCATE 3+AYSIZE+l, 15: PRINT CHR$( 192);

2630 FOR 1=1 TO AXSIZE: LOCATE 3+AYSIZE+l, 15+1: PRINT CHR$( 196);: NEXT I 2640 PRINT CHR$(217);

2650 REM #«*« DRAW BOX AROUND B FIELD ***#

2660 LOCATE 3,55: PRINT CHR$(218)

2670 FOR 1=1 TO BXSIZE: LOCATE 3,55+1: PRINT CHR$(196);: NEXT I 2680 PRINT CHR$(191);

2690 FOR J=1 TO BYSIZE

2700 LOCATE 3+J,55: PRINT CHR$(179);

2710 LOCATE3+J,55+BXSIZE+l: PRINTCHR$(179);

2720 NEXT J

2730 LOCATE 3+BYSIZE+l, 55: PRINT CHR$( 192)

2740 FOR 1=1 TO BXSIZE: LOCATE 3+BYSIZE+l,55+1: PRINT CHR$( 196);: NEXT I 2750 PRINT CHR$(217);

1. LEARN CURRENT PATTERN";

ARROW KEYS TO MOVE CURSOR";

2. ADD RANDOM NOISE";

A ORB TO SWITCH FIELDS"

3.

2760 LOCATE 21,1:PRINT "OPTIONS: 2770 LOCATE 21,41: PRINT "

2780 LOCATE 22,1:PRINT "

2790 LOCATE 22,4l:PRINT "

2800 LOCATE 23,1:PRINT "

2810 LOCATE 23,41:PRINT "

2820 LOCATE 24,1:PRINT "

2830 LOCATE 24,4l:PRINT "

2840 LOCATE 25,1:PRINT »

2870

2880

2890

2900

2940

2950

2960

2970

RUN THE NETWORK";

+ TO SET LEVEL TO 1";

4. CLEAR A AND B FIELDS";

-TO SET LEVEL TOO";

ESC. RETURN TO MAIN MENU";

2850 REM **** DISPLAY THE A FIELD ARRAY IN THE BOX *»**

2860 FOR J=1 TO AYSIZE FOR 1=1 TO AXSIZE LOCATE 3+J, 15+1

PRINT CHR$(219*A*((J-1)*AXSIZE+I));

NEXT I 2910 NEXT J

2920 REM ***# DISPLAY THE B FIELD ARRAY IN THE BOX ****

2930 FOR J=1 TO BYSIZE FOR 1=1 TO BXSIZE LOCATE 3+J,55+1

PRINT CHR$(219*B*((J-1)#BXSIZE+I));

NEXT I 2980 NEXT J 2990 RETURN

3000 REM a###########################*##########*###########*

3010 REM EDIT THE A AND B FIELDS

3020 REM *tt*ttttfto**tttt*ttft**tttt*JUtt*tttt*ft**«**ft******tf****tf******

3030 GOSUB 2480 ' DISPLAY THE FIELDS BEFORE EDITING

3040 PX=1: PY=1: FLD=0 'START ON A FIELD UPPER LEFT CORNER 3050 S$=INKEY$ • GET KEYBOARD ENTRY

3060 LOCATE 3+PY, 15+PX+40*FLD ' POSITION CURSOR IN FIELD BOX

3070 PRINT "*";

3080 FOR ZZ=1 TO 4: NEXTZZ

3090 LOCATE 3+PY, 15+PX+40#FLD

3100 IF FLD=0 THEN XSIZE=AXSIZE: YSIZE=AYSIZE

3110 IF FLD=1 THEN XSIZE=BXSIZE: YSIZE=BYSIZE

3120 OFS=((PY-1)#XSIZE+PX)

3130 IF FLD=0 THEN STAT=A*(OFS) ELSE STAT=B£(OFS)

3140 PRINT CHR$(219#STAT);

3150 IF LEN(S$)*2 THEN S$=RIGHT$(S$,1)

3160 IF S$=CHR$(77) THEN PX=PX+1

3170 IF S$=CHR$(75) THEN PX=PX-1

3180 IF S$=CHR$(72) THEN PY=PY-1

3190 IF S$=CHR$(80) THEN PY=PY+1

3200 IF S$="A" OR S$="a" THEN FLD=0: PX=1: PY-1

3210 IF S$*"B" OR S$*"b" THEN FLD=1: PX-1: PY=1

3220 IF S$="+" AND FLD=0 THEN AJt(OFS) =1

3230 IF S$="+" AND FLD=1 THEN B£(0FS)=1 3240 IF S$="-" AND FLD=0 THEN AJt(OFS) =0 3250 IF S$="-" AND FLD=1 THEN BJf(OFS) =0 3260 IF S$="l" THEN GOSUB 3370 3270 IF S$="2" THEN GOSUB 3530 3280 IF S$="3" THEN GOSUB 3660 3290 IF S$="4" THEN GOSUB 4150 3300 IF PX<1 THEN PX=1

' LEARN CURRENT PATTERN ' ADD RANDOM NOISE TO PATTERN ' RUN THE NETWORK r CLEAR THE A AND B FIELDS

3310 IF PX>XSIZE THEN PX=1: PY=PY+1 3320 IF PY<1 THEN PY=1 3330 IF PY>YSIZE THEN PY=YSIZE 3340 IFS$=CHR$(27) THEN RETURN 3350 FOR ZZ=1 TO 4: NEXT ZZ 3360 GOTO 3050

3370 REM ####################################################

3380 REM LEARN CURRENT PATTERN IN A AND B FIELDS

3390 REM a######*####*###*########*############*######*######

3400 FOR 1=1 TO AXSIZE»AYSIZE • TRANSFER A FIELD TO BIPOLAR X FIELD

3410 IF A*( I) =0 THEN X*( I) =-l ELSE X*( I) =1 3420 NEXT I

3430 FOR 1=1 TO BXSIZE#BYSIZE ' TRANSFER B FIELD TO BIPOLAR Y FIELD

3440 IF B£(I)=0 THEN Y*(I) =-l ELSE Y*(I) =1 3450 NEXT I

3460 REM **** THE CORRELATION MATRIX M IS UPDATED HERE *#*#

3470 FOR J=1 TO BXSIZE#BYSIZE 3480 FOR 1=1 TO AXSIZE#AYSIZE 3490 M*(I,J)=M*(I,J) + X*(I)*Y*(J)

3500 NEXT I 3510 NEXT J 3520 RETURN

3530 REM

3540 REM add RANDOM NOISE TO THE A AND B FIELDS

3550 REM

3560 FOR 1=1 TO AXSIZE#AYSIZE 3570 IF 100#RND>=NOISE THEN 3590

3580 IF A*( I) =0 THEN A*( I) =1 ELSE A*(I) =0 • FLIP THE STATE

3590 NEXT I

3600 FOR 1=1 TO BXSIZE#BYSIZE 3610 IF 100#RND>=NOISE THEN 3630

3620 IF B£(I)=0 THEN B*(I) =1 ELSE BJt(I)=0 'FLIP THE STATE 3630 NEXT I

3640 GOSUB 2850 ' UPDATE THE A AND B FIELD DISPLAYS

3650 RETURN

3660 REM

3670 REM RUN ITERATIONS OF THE NETWORK

3680 REM *******#############################################

3690 IF ASYN=0 THEN GOTO 3940

3700 REM #### PERFORM ASYNCHRONOUS UPDATE OF ASYN RANDOM NEURONS/FIELD #*## 3710 FOR CC=1 TO 10 ' LIMIT THE NUMBER OF ASYNCHRONOUS ITERATIONS

3720 FOR K=1 TO ASYN

PIK=INT((AXSIZE#AYSIZE)#RND+1)

TSUM = 0

FOR J=1 TO BXSIZE*BYSIZE ' UPDATE A FIELD NEURON

TSUM = TSUM + B*(J)#M*(PIK,J)

NEXT J

IF TSUM>0 THEN A£(PIK)=1 ' THRESHOLD FUNCTION

IF TSUM<0 THEN A*(PIK) =0 NEXT K

FOR K=1 TO ASYN

PIK=INT((BXSIZE*BYSIZE)#RND+1)

TSUM = 0

FOR 1=1 TO AXSIZE#AYSIZE ' UPDATE B FIELD NEURON

TSUM- TSUM + A*(I)#M*(I, PIK)

NEXT I

IF TSUM>0 THEN BJt(PIK) =1 ' THRESHOLD FUNCTION

IF TSUM<0 THEN B%(PIK)=0 NEXT K

GOSUB 2850 ' WANT TO WATCH THE PROGRESS

3910 NEXT CC

3920 RETURN ' COMPLETED ASYN ITERATION

3930 REM **** PERFORM SYNCHRONOUS UPDATE OF ALL NEURONS IN BOTH FIELDS #### 3940 FOR CC = 1 TO 2 • ONLY TWO ITERATIONS NEEDED

3950 FOR J«1 TO BXSIZE&BYSIZE TSUM = 0

FOR 1=1 TO AXSIZE#AYSIZE • UPDATE B FIELD NEURON

3730

3740

3750

3760

3770

3780

3790

3800

3810

3820

3830

3840

3850

3860

3870

3880

3890

3900

3960

3970

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 119

3980 TSUM = TSUM + A*(I)#M*(I,J)

3990 NEXT I

4000 IF TSUM>0 THEN B% (J) =1 • THRESHOLD FUNCTION

4010 IFTSUM<0 THEN B%(J)=0

4020 NEXT J

4030 FOR 1=1 TO AXSIZE*AYSIZE 4040 TSUM = 0

4050 FOR J=1 TO BXSIZE*BYSIZE ' UPDATE A FIELD NEURON

4060 TSUM = TSUM + BJt(J)#M5C(I,J)

4070 NEXT J

4080 IF TSUM>0 THEN A*(I)=1 » THRESHOLD FUNCTION

4090 IF TSUM<0 THEN A*(I)=0

4100 NEXT I

4110 GOSUB 2850 ' UPDATE THE A AND B FIELD DISPLAYS

4120 NEXT CC < ITERATION OF BOTH FIELDS 4130 RETURN 4140 RETURN

4150 REM KM#####*##########*###############*##

4160 REM CLEAR THE A AND B FIELDS

4170 REM ###########################*#########

4180 FOR 1=1 TO 144 4190 A*(I)=0

4200 B*(I)=0

4210 NEXT I

4220 GOSUB 2850 ' UPDATE THE A AND B FIELD DISPLAYS

4230 RETURN

4240 REM a########################*##*#######################

4250 REM LOAD CORRELATION MATRIX M FROM DISK FILE

4260 REM ################*#####*###########*###########*#####

4270 CLS

4280 PRINT " CURRENT MEMORY MATRIX FILES ON DISK"

4290 PRINT 4300 FILES"#. BAM"

4310 PRINT 4320 PRINT

4330 INPUT " ENTER FILENAME TO LOAD MEMORY MATRIX : FILESPEC$

4340 IF FILESPEC$ = " " THEN RETURN

4350 IF INSTR(".",FILESPEC$) =0 THEN FILESPEC$ = FILESPEC$ + ".BAM"

4360 OPEN FILESPEC$ FOR INPUT AS 01 4370 INPUT 01, AXSIZE 4380 INPUT 01, AYSIZE 4390 INPUT 01, BXSIZE 4400 INPUT 01, BYSIZE 4410 FOR J=1 TO BXSIZE#BYSIZE 4420 FOR 1=1 TO AXSIZE#AYSIZE 4430 INPUT 01, M*(I,J)

4440 NEXT I 4450 NEXT J 4460 CLOSE 01 4470 RETURN

4480 REM #######################lHHMHHHHHHHHHHHHHHHHHHHHHHHHHt 4490 REM SAVE CORRELATION MATRIX M IX) DISK FILE

4500 REM tHHHHHHHHHHUHHHHHHHHHHMHHHHHHHHHHHHUHHHHHUHHHUHHHUHHt 4510 CLS

4520 PRINT " CURRENT MEMORY MATRIX FILES ON DISK"

4530 PRINT 4540 FILES "#.BAM"

4550 PRINT 4560 PRINT

4570 INPUT " ENTER FILENAME TO SAVE MEMORY MATRIX : "; FILESPEC$

4580 IF FILESPEC$ = " " THEN RETURN

4590 IF INSTR(".",FILESPEC$) « 0 THEN FILESPEC$ • FILESPEC$ + ».BAH”

4600 OPEN FI LESPECJ FOR OUTPUT AS #1 4610 PRINT #1, AXSIZE 4620 PRINT #1, AYSIZE 4630 PRINT #1, BXSIZE 4640 PRINT #1, BYSIZE 4650 FOR J*1 TO BXSIZE*BYSIZE 4660 FOR 1=1 TO AXSIZE*AYSIZE 4670 PRINT #1, M*(I,J)

4680 NEXT I 4690 NEXT J 4700 CLOSE #1 4710 RETURN

4720 IF ERL.4540 THEN PRINT "NO FILES": RESUME 4550 4730 IF ERL=4300 THEN PRINT "NO FILES": RESUME 4310

4740 RESUME 1790 4750 CLOSE 4760 ON ERROR GOTO 0 4770 END

SORTELEM.MOD From "Programming Project: Crafting Reusable Software in Modula-2" by Hanna Oktaba and Rene Berber, BYTE, September 1987.

IMPLEMENTATION MODULE SortElemType;

(* FROM FileDescriptor IMPORT FlleDescr; #)

FROM InOut IMPORT in, ReadString, WriteString, WriteLn, Write;

FROM Storage IMPORT ALLOCATE;

FROM Strings IMPORT Length, Concat, Copy;

CONST

EOS = OC; (# End Of String #)

TYPE

ElemType = POINTER TO FileDescr;

FileDescr = REC0RD(# File descriptor #) name : ARRAY [0. .8] OF CHAR; ext : ARRAY [0..3] OF CHAR; size : ARRAY [0..7] OF CHAR; date : ARRAY [0. .8] OF CHAR; time : ARRAY [0..6] OF CHAR

comp : PROCEDURE (ElemType, ElemType): BOOLEAN;

PROCEDURE compare (x, y: ElemType): BOOLEAN;

BEGIN (# call the procedure currently #)

RETURN comp(x,y) (# assigned to "comp"#)

END compare;

PROCEDUREcompName (rl, r2: ElemType): BOOLEAN;

BEGIN

RETURN Str ingComp (rl*. name, r2*. name)

END compName;

PROCEDURE compExt (rl, r2: ElemType): BOOLEAN;

VAR tempi, temp2 : ARRAY [0. .12] OF CHAR;

BEGIN (# compare by extension and then by name #)

Concat(rl*.ext,".",tempi); Concat(tempi,rl*.name,tempi); Concat(r2*.ext,".",temp2); Concat(temp2,r2*.name,temp2); RETURN Str ingComp (tempi, temp2)

END compExt;

»)

*)

*)

*)

PROCEDURE optionMenu;

BEGIN

WriteString("options:"); WriteLn;

WriteString(" 1 to sort by filename"); WriteLn;

WriteString(" 2 to sort by extension"); Wri teLn;

WriteString(" the default is 1, any other is taken ns 1"); WriteLn; WriteLn END optionMenu;

PROCEDURE ReadArray(VAR A: ARRAY OF ElemType): CARDINAL;

VAR n, max : CARDINAL;

temp : ARRAY [0. .8] OF CHAR;

PROCEDURE select (option: CARDINAL);

BEGIN

CASE option OF ( m compare by:

1 : comp := compName (# filenames

| 2 : comp := compExt (#extension

ELSE comp: s compName (# default

END

END select;

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 121

BEGIN

n:= 0; max: = HIGH(A);

ReadStrlng(temp);

WHILE (NOT in.eof) & (n< max) DO NEW(A[n]);

Copy(temp,0,30,A[n]".name);

ReadString(A[n]".ext);

ReadString(A[n]".size);

ReadString(A[n]".date);

ReadString(A[n]*.time);

ReadString(temp); INC(n)

END;

RETURN n END ReadArray;

PROCEDURE WriteArray (A: ARRAY OF ElemType; n: CARDINAL);

VAR i : CARDINAL;

BEGIN

FOR 1: = 0 TO n-1 DO

WriteFString(A[i]".name,-ll); WriteFString(A[i]".ext,-6);

WriteFString(A[i] \ size,12);

WriteFString(A[i]".date,10); WriteFString(A[i]".time,8); WriteLn

END

END WriteArray;

PROCEDURE WriteFString (s: ARRAY OF CHAR; f: INTEGER);

(* Write string "s" formated in a field of size f.

IF f < 0 string is left Justified IFf>0 string is right Justified IF Length(s)> f string is truncated padding is done with blanks

*)

VAR i, n: INTEGER; c : CHAR;

BEGIN

n:= Length(s);

IF f > 0 THEN FOR i:* 1 TO f-n DO Write( • ») END END; i: = 0;

REPEATc:«s[i]; Write(c); INC(i)

UNTIL (i>= n) OR (i>= ABS(f));

IFf < OTHENFOR i:= 1 TO-f-n DO Write( * ') END END END WriteFString;

PROCEDURE StringComp (si, s2: ARRAY OF CHAR)

(# returns sl< s2 *)

VAR i, max : CARDINAL;

BEGIN

i:=0; max:= HIGH(sl);

WHILE (i< max) & (sl[i] * s2[i]) DO IF sl[i] = EOS THEN RETURN FALSE ELSE INC(i)

END

END;

RETURN sl[i]<s2[i]

END StringComp;

BEGIN

comp:= compName (# default #)

END SortElemType.

: BOOLEAN;

(#sl = s2#)

SORTTEST.MOD From "Programming Project: Crafting Reusable Software in Modula-2" by Hanna Oktaba and Rene Berber, BYTE, September 1987.

(««***

«

* Test of generic sorting routine

ft

ftftftftft)

MODULE SortTest;

FROM InOut IMPORT Openlnput, Closelnput, WriteString, WriteLn, ReadCard, OpenOutput, CloseOutput;

FROM Sort IMPORT Qsort;

FROM SortElemType IMPORT ElemType, select, optionMenu,

ReadArray, WriteArray;

CONST

N = 200;

VAR

a : ARRAY [1. .N] OF ElemType;

n : CARDINAL: (# actual number of elements in "a" #)

opt : CARDINAL;

BEGIN

WriteString("Which file contains the data ? ");

OpenInput(""); n:= ReadArray(a);

Closelnput;

optionMenu;

WriteString("Sort by ? ");

ReadCard (opt); WriteLn; select(opt);

Qsort(a,n);

WriteLn; WriteString("Output file [ Esc for console ] ? ");

OpenOutput("");

WriteArray(a,n);

CloseOutput END SortTest.

SORTELEM.DEF From "Programming Project: Crafting Reusable Software in Modula-2" by Hanna Oktaba and Rene Berber, BYTE, September 1987.

Note 1

Note 2

Note 3

TYPE

Note 4

Note 5

Note 6

Note 7

Note 8

Note 9

Note 10

Note 11

Note 12

Note 13

Note 14

PROCEDURE select (option: CARDINAL);

(* input: output:

*)

- a number denoting the requested option

- the exported compare procedure gets assigned to one of the comparison procedures.

- the option should be valid; otherwise a default may be used

PROCEDURE optionMenu; (# output:

■ displays on the screen the available options. #)

(* * pointer to data element *)

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 123

PROCEDURE ReadArray(VAR A: ARRAY OF ElemType): CARDINAL;

(* input: - an array of pointers, declared by the user module.

output: - the array is filled with pointers to the memory used by the elements

read, and the number of them is returned, errors: - can run out of memory.

NOTE: If the file contains more elements than those that can be stored in the array, they are ignored.

*)

PROCEDURE WriteArray(A: ARRAY OF ElemType; n: CARDINAL) ;

(* input: - an array of pointers, and the number of elements.

output: - the elements are written to current output of InOut.

*)

END SortElemType.

SORT.MOD From "Programming Project: Crafting Reusable Software in Modula-2" by Hanna Oktaba and Rene Berber, BYTE, September 1987.

IMPLEMENTATION MODULE Sort;

FROM SortElemType IMPORT ElemType, compare;

PROCEDURE Qsort (VARA: ARRAY OF ElemType; N: CARDINAL);

PROCEDURE sort (1, r: INTEGER); (# N. Wirth '86 *)

VAR i, J : INTEGER;

x, w : ElemType;

BEGIN

i:* 1; J:« r; x:» A[(l+r) DIV 2];

REPEAT

WHILE compare(A[i],x) DOINC(i) END;

WHILE compare(x,A[j]) DODEC(J) END;

IF i <= J

THEN w: = A[i]; A[i]:« A[J]; A[J]:=w;

INC(i); DEC(J)

END;

UNTIL i > J ;

IF 1 < J THEN sort(l,J) END;

IF i < r THEN sort(i,r) END END sort;

BEGIN

IF N > HIGH(A)+1 THEN N: = HIGH(A)+1 END; sort(0,N-l)

END Qsort;

END Sort.

ADD-PATT.C From "Constructing an Associative Memory" by Bart Kosco, BYTE, September 1987.

i*

ADD-PATT ADDS A PATTERN TO THE BAM MATRIX XTY

COPYRIGHT (C) 1987, JOEL S. DAVIS. AFTER BYTE PUBLICATION, APPROVED FOR NONCOMMERCIAL USE ONLY.

»/

#include "STRUCT.H"

^include "EXT.H" add_patt(an,bn) lnt #an,*bn;

{

int 1,J;

124 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

/* MAKE VECTORS BIPOLAR #/ for(i=0;i<#an;i++){ if(a[i]<=0){ x[i] =-1;

}else{

}

}

for(J=0;j<#bn;J++){ if(b[j]<=0){

y[J] »-i;

}else{

y[J] = 1;

}

}

I* UPDATE XTY »/

for(i=0;i<#an;i++){

for(j=0;J<#bn;J++){

xty[i][J] += x[i]#y[J];

}

}

/* SIGNAL COMPLETION #/

putchar(BELL);

}

SORT.DEF From "Programming Project: Crafting Reusable Software in Modula-2" by Hanna Oktaba and Rene Berber, BYTE, September 1987.

DEFINITION MODULE Sort;

FROM SortElemType IMPORT ElemType, compare;

(# Module SortElemType is used to define the kind of element to be sorted *) EXPORT QUALIFIED Qsort;

PROCEDURE Qsort (VARA: ARRAY OF ElemType; N: CARDINAL);

(# input: - array of pointers to elements, and number of elements

* [ N <= HIGH(A)+1 ].

* output: -the array of pointers is rearranged so they point to the

# elements in sorted order.

# requires that ElemType has a total order relation named "compare".

*)

END Sort.

README.BAM From "Constructing an Associative Memory" by Bart Kosco, BYTE, September 1987.

TO RUN BAM:

FILESBAM.COM, BAM.PAS, XFACE.INC, PAT1(NOT NECESSARY) README.BAM- this file > BAM

*# RUNS THE PROGRAM **

SYSTEM REQUIREMENTS: COLOR MONITOR (CGA) OR Mono Graphics TURBO PASCAL (FOR EDITING)

STATUS LINE: PRESSA, S, H, ORQ

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 125

ANSWER YES/NO QUESTIONS WITH Y OR N <RETURN>.

PAT1 is a sample pattern file.

code 15,712 bytes data 49,424 bytes

FFI: Dr. Rod Taber

General Dynamics

Electronics Division Mail Zone 7202-K Box 85310

San Diego, CA 92138

Mail without Mail Zone takes 3 months.

AWAIT.C From "Constructing an Associative Memory" by Bart Kosco, BYTE, September 1987.

/*

AWAIT ASKS THE USER FOR ANOTHER KEY ENTRY AFTER N RETURNS */

await(im) int im;

{

int i;

for(i=0;i<im; i++){ printf("\n");

}

printf ("Press any key to continue: "); getchar();

ASYNCH.C From "Constructing an Associative Memory" by Bart Kosco, BYTE, September 1987.

/*

ASYNCH ASYNCHRONOUSLY UPDATES THE BAM

COPYRIGHT (C) 1987, JOELS. DAVIS. AFTER BYTE PUBLICATION, APPROVED FOR NONCOMMERCIAL USE ONLY.

*/

^include "STRUCT.H"

^include "EXT.H"

asynch(axn,ayn,bxn,byn,an,bn,n_asyn) int #axn,#ayn,#bxn,#byn,#an,#bn,n_asyn;

int i,J,k,l,m,n,index,iter,sum; int seed; char buf[9]; double x,frand();

/# GET A RANDOM NUMBER SEED FROM THE SYSTEM CLOCK * /

/ * READ THE CLOCK #/ times(buf);

/* GENERATE THE SEED INTEGER #/ seed « (int) (buf[7] - '0'); seed +« seed + 10 # ((int) ((buf[6] - ’0'))); seed -f= seed + 60 # ((int) ((buf[4] - *0'))); seed +* seed+ 600* ((int) ((buf[3] - r 0'))); srand(seed);

126 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

/* GO THROUGH 10 ITERATIONS * / iter = 10;

for(k=0;k<iter;k++){

/ * UPDATE N_ASYN NEURONS * /

for(n=0;n<ruasyn;n++){ sum = 0;

/ * PROCESS B VECTOR NEURON * /

/* WHICH NEURON DO I UPDATE THIS TIME ? »/

x = (double) #bn; x#= frand(); x += 0.5;

J = (int) x;

/ * APPLY ALL A VECTOR INPUTS * /

for(i=0;i<*an;i++){

sum += a[i] # xty[i][j];

NOW DO THRESHOLDING */ if(sum>0){ b[J)-l;

}else if(sum<0){ b[J] =0;

}else{

RETAIN VALUE #/ continue;

}

vec_show(axn,ayn,bxn,byn);

/ * NOW IN REVERSE TO PROCESS A VECTOR NEURONS # /

/ * UPDATE N_ASYN NEURONS * /

for(n=0;n<n_asyn;n++){ sum = 0;

I * PROCESS B VECTOR NEURON # /

/* WHICH NEURON DO I UPDATE THIS TIME ? #/

x = (double) #an; x #= frand(); x+= 0.5; i » (int) x;

/ * FOR EACH A VECTOR NEURON, APPLY ALL B VECTOR INPUTS # /

for(J=0;J<#bn;J++){ j sum+« b[J] * xty[i][J];

/* NOW DO THRESHOLDING */

if(sum>0){

a[i]«l;

}else if(sum<0){

a[i] -0;

)else{

/# RETAIN VALUE »/

continue;

vec.show(axn,ayn,bxn,byn);

} }

/»

/«

}

SIEVE386.ASM Accompanies "The Kaypro 386" by Ray Duncan, BYTE, September 1987.

Title "Eratosthenes Sieve for 80386" Name Sieve Page 50,132

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 127

Eratosthenes Sieve for 80386 32-bit protected mode

Implemented by Ray Duncan, April 1987

After Gilbreath, BYTE, September 1981 and January 1983

Here is the MAKE file for this program:

sieve386.obj : sieve386.asm 386asm sieve386

sieve386.exe : sieve386.obj

386link sieve386 start386 -exe sieve386 -map sieve386 To run the program with Phar Lap D0S|EXTENDER:

; -ORUN386 SIEVE386 i

niter

equ

100

; number of iterations

asize

equ

8190

; size of array "flags"

cr

equ

Odh

; ASCII carriage return

If

equ

Oah

; ASCII linefeed

stdin

equ

0

; handle for standard input

stdout

equ

1

; handle for standard output

_TEXT

segment para public use32 1

'CODE'

assume cs: _TEXT, ds:_DATA,

es: JDATA

public _start_

; magic name for RUN386 entry

_start_

proc

near

xor

edx,edx

; convert number of iterations

mov

eax,niter

; for output

mov

ecx,10

mov

esi,offset msgla+3

call

binasc

mov

edx, offset msgl

; display message

mov

ecx,msgJLlen

; "StartingN iterations of Sieve

call

pmsg

call

getmsec

; get current time in msec

push

eax

; and save it...

mov

counter,niter

; initialize iterations counter

slevel:

; a sieve iteration starts here..

mov

edi,offset flags

; initialize flags array

mov

ecx,asize

; to all bytes = TRUE

mov

al,l

cld

rep stosb

xor

esi,esi

; ESI = index to flags array

xor

edi,edi

; EDI = primes counter

sleve2:

; main loop of sieve

test

byte ptr flags[esi]

,1 i is this a prime?

Jnz

short sieve4

; Jump if prime

sieve3:

Inc

esi

; bump to next slot in "flags"

cmp

esi,asize

Jle

sieve2

; loop until array exhausted

dec

counter

; count off sieve iterations

Jnz

slevel

; Jump, another iteration needed.

Jmp

sieve7

; Jump, all iterations finished.

sieved:

; prime found, zap its multiples

mov

ebx,esi

; copy i

mov

edx,ebx

; EDX * prime = i + i + 3

add

edx,edx

add

edx, 3

128 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

xor al,al

Jmp short sieve6

sieve5: mov byte ptr flags[ebx] ,al; zero this multiple

sieve6:

add

ebx,edx

emp

ebx,asize

Jle

sieved

inc

edi

Jmp

sieve3

sieve7:

call

getmsec

push

eax

mov

eax,edi

mov

edx,0

mov

ecx,10

mov

esi,offset msg2a+4

call

binasc

mov

edx, offset msg2

mov

ecx,msg2_len

call

pmsg

pop

eax

pop

ebx

sub

eax,ebx

mov

edx,0

mov

ecx,niter

idiv

ecx

mov

edx,0

mov

ecx,10

mov

esi,offset msg3a+4

call

binasc

mov

edx, offset msg3

mov

ecx,msg3_len

call

pmsg

mov

ax,04C00h

int

21H

_start_

endp

getmsec

proc

near

mov

ah,2ch

int

21h

movzx

eax,ch

imul

eax,60

and

ecx,0ffh

add

eax,ecx

imul

eax,60

movzx

ecx,dh

add

eax,ecx

and

edx,0ffh

imul

eax,100

add

eax,edx

imul

ret

eax,10

Table captiongetmsec endp

Table caption; find next multiple of prime ; have we exhausted the array? ; not yet, zap it ; count primes and try next

Table caption; all done, get current time

Table caption; convert number of primes ; found on last iteration

Table caption; display "Number of primes: "

Table caption; calculate total elapsed msec.

Table caption; divide by number of iterations ; to get msec per iteration

Table caption; convert msec to ASCII

Table caption; display "Elapsed time:"

Table caption; final exit, return code = 0

; Return EAX = current time in msec.

; read time

; EAX : ■ hours ; hours -> minutes ; isolate system minutes ; and find total minutes ; minutes -> seconds ; isolate system seconds ; and find total seconds ; isolate hundredths ; seconds -> hundredths ; find total hundredths ; hundredths -> msec

; BINASC: Convert 64-bit binary value to ASCII string. i

i Call with EDX:EAX = signed 64-bit value ; ECX ■ radix

; DS:ESI = last byte of area to store resulting string

i (make sure enough room is available to store

i the string in the radix you have selected.)

i

; Destroys EAX, EBX, ECX, EDX, and ESI.

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 129

binasc

proc

near

; convert EDX:EAX to ASCII.

mov

byte ptr [esi], 'O'

; force storage of at least one digit.

or

edx,edx

; test sign of 64-bit value,

pushf

; and save sign on stack.

jns

binl

; Jump if it was positive.

not

edx

; negative, take 2's complement

not

eax

; of the value.

add

eax,l

adc

edx,0

binl:

mov

ebx,eax

; divide 64-bit value by the radix ; to extract next digit for the ; forming string.

; is the value zero yet?

or

ebx,edx

Jz

bin3

; yes, we are done converting.

call

divide

; no, divide by radix.

add

bl,'0»

; convert remainder to ASCII digit.

cmp

bl,*9*

; might be converting hex ASCII,

Jle

bin2

; Jump if in range 0-9,

add

bl, , A'- , 9 , -l

; correct it if in range A-F.

bin2:

mov

[esi],bl

; store this character into string.

dec

esi

; back up through string,

Ji"P

binl

; and do it again.

bin3:

popf

; restore sign flag,

; was original value negative?

jns

bin4

; no, jump

mov

byte ptr [esi],

; yes, store sign into output string.

bin4:

ret

; back to caller.

binasc endp

; General-purpose 64-bit by 32-bit unsigned divide.

; This must be used instead of the plain machine unsigned divide ; for cases where the quotient may overflow 32 bits. If called with

; zero divisor,

this routine returns the dividend unchanged and gives

; no warning.

; Call with EDX:EAX = 64-bit dividend

ECX

=divisor

; Returns EDX:EAX = quotient

EBX

= remainder

ECX

= divisor (unchanged)

divide

proc

near

; Divide EDX:EAX by ECX

Jecxz

divl

; exit if divide by zero

push

eax

; O:dividend_upper/divisor

mov

eax,edx

xor

edx,edx

div

ecx

mov

ebx,eax

; EBX a quotientl

pop

eax

; remainderl:dividendLlower/divisor

div

ecx

xchg

ebx,edx

; EDX:EAX = quotientl:quotient2

divl:

ret

; EBX = remainder2

divide

endp

pmsg

proc

near

; print a message on std output ; call with DS:EDX » address

; ECX =length

mov

ah,40h

mov

bx,stdout

int

21h

Table captionpmsg

Table captionret

Table captionendp

_TEXT

ends

_DATA segment para public use32 'DATA'

130 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

flags

db

asize+1 dup (?)

counter

dd

? .

msgl

db

cr,If,'Starting '

msgla

db

' iterations of Sieve.

msgl_len

equ $-msgl

msg2

db

or. If,' Primes found: 1

msg2a

db

' ',cr,lf

msg2_len

equ $-msg2

msg3

db

cr, If,' Elapsed time: '

msg3a

db

' msec, per iteration'

msg3_len

equ $-msg3

-DATA

ends

-STACK

segment byte stack use32 ’stack'

db

4096 dup (?)

-STACK

ends

end

Table captioni sieve iteration counter

GET_MTX.C

From "Constructing an Associative

\

Memory" by Bart Kosco, BYTE, September 1987.

/*

GET_MTX GETS THE VALUES FOR AN XTY MEMORY MATRIX FROM MASS STORAGE

COPYRIGHT (C) 1987, JOELS. DAVIS. AFTER BYTE PUBLICATION, APPROVED FOR NONCOMMERCIAL USE ONLY. */

^include <c: \cware\stdio.h>

^include <struct.h>

0include <ext.h>

ge t_mtx(axn,ayn,bxn,byn,an,bn)

int *axn,*ayn,#bxn,#byn,*an,*bn;

int i,J,total;

FILE #f3,#fopen(); char fname[40];

for(;;){

for(i=0; i <40; i++) fname[i] *0; clsO();

printf("\n\n\nPlease enter name of file containing memory values"); printf( "\nyou wish to restore: "); scanf("|s",fnamc);

/* OPEN INPUT FILE #/

if ((f>fopcn( fnnmo, "r")) --NULL) { printf("\nCan't open INPUT FILE |s\n", fname); printf("\nTry againl Hit [ENTER] to continue... "); getchar();

}else{

break;

}

}

/* CLEAR THE BAM »/ clearbam();

/* READ HORIZONTAL AND VERTICAL DIMENSIONS OF A AND B ARRAYS */ fscanf (f3,"Id Id Id |d",axn,nyn,bxn,byn); printf("\n\n Reading A array Id x Id and B array |d x Id",

#axn,#ayn,*bxn,#byn);

*an * (#axn) * (#ayn);

#bn ■ (#bxn) # (#byn); total« (#an) * (#bn);

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 131

printf("\n*dx$d xTy -> $d lines to be read! ",#an,*bn,total); printf("\nDepending upon your machine, this could take a minute or so...");

for(i=0;i<*an;i++){ for(j=0;j <#bn;j++){ fscanf(f3/'$d",&xty[i] [j]);

}

}

fclose(f3);

}

PAT1 From "Constructing an Associative Memory" by Bart Kosco, BYTE, September 1987.

4

4

8

6

10

11111111100000011111111110000001

000111000000001100000000110000000011000000001100000001111000

11111111000110000001100000011000

011111111011000000110000000011000111111001110000001111111111

11111111100000011000000111111111

110001100011000110001100011000111111111100000110000000011000

11100111101111011001100110000001

111111111100000000110000001110000011100000111000001110000000

EXT.H From "Constructing an Associative Memory" by Bart Kosco, BYTE, September 1987.

/*

BAM PARAMETER ARRAYS

COPYRIGHT (C) 1987, JOELS. DAVIS. AFTER BYTE PUBLICATION, APPROVED FOR NONCOMMERCIAL USE ONLY.

*/

extern int a[DIMENl],b[DIMEN2],x[DIMENl],y[DIMEN2],xty[DIMENl][DIMEN2]; extern int newvecl[DIMENl],newvec2[DIMEN2];

BAM.C From "Constructing an Associative Memory" by Bart Kosco, BYTE, September 1987.

/•

PROGRAM BAM

==========================

BY

JOELS. DAVIS

1310 CONSTITUTION COURT, NE ALBUQUERQUE, NM 87112

THIS PROGRAM IS A SIMPLE IMPLEMENTATION OF THE BIDIRECTIONAL CORRELATION MEMORY ALGORITHM DEVELOPED BY BART KOSKO. THE SOURCE CODE IS WRITTEN FOR DESMET C BY CWARE RUNNING UNDER MS-DOS.

IT COMBINES FEATURES FROM THE DUANE DESIENO BAM PROGRAM, WRITTEN IN BASIC, AND MY OWN ASSOC AND BASSOC PROGRAMS, WRITTEN IN C.

THIS VERSION IS DATED: 7-AUGUST-1987

COPYRIGHT (C) 1987, JOELS. DAVIS. AFTER BYTE PUBLICATION, APPROVED FOR NONCOMMERCIAL USE ONLY.

*/

132 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

^include <\cware\stdio.h >

^include <\cware\math.h>

^include <struct.h>

Int a[DIMENl],b[DIMEN2],x[DIMENl],y[DIMEN2],xty[DIMENl][DIMEN2]; int newvecl[DIMENl],newvec2[DIMEN2];

main(argc,argv) int argc; char ##argv;

{

int i, j ,k,l,m,n,d2; int op;

int axn,ayn,bxn,byn,n_asyn,pct_noise,an,bn;

/* INITIALIZE DIMENSIONS */

clearbam();

initial(&axn,&ayn,&bxn,&byn,&an,&bn,&n_asyn,&pc t__no ise);

/* INTRODUCTION #/

intro();

/* PRESENT MAIN MENU */

f°r(;;){

op = mainmenu();

if(op == l){

/ * NEW PROGRAM PARAMETERS # /

nev_parm( &axn, &ayn, &bxn, &byn, &an, &bn, &n_asyn, &pct_noise);

}else if(op==2){

I * CLEAR VECTORS AND BAM * /

clearbam();

}else if(op==3){

/ * LOAD THE MEMORY MATRIX » /

ge t_mtx (&axn, &ay n, &bxn, &byn, &an, &bn);

}else if(op==4){

/* SAVE THE MEMORY MATRIX # /

save_mtx(&axn,&ayn,&bxn,&byn,&an,&bn);

}else if(op==5){

/ * OPERATE ON MEMORY AND RUN BAM # /

rurubam(&axn,&ayn,&bxn,&byn,&an,&bn,n_asyn,pc t_noise);

}else if(op==6){

/* QUIT */

break;

CLEARBAM.C From "Constructing an Associative Memory" by Bart Kosco, BYTE, September 1987.

/»

CLEARBAM CLEARS ALL BAM VECTORS AND THE XTY MATRIX

COPYRIGHT (C) 1987, JOEL S. DAVIS. AFTER BYTE PUBLICATION, APPROVED FOR NONCOMMERCIAL USE ONLY.

*/

^include <STRUCT.H>

^include <EXT.H>

clearbam()

{

int d2;

/ * SET MATRICES TO ZERO * / zero_ld(a,DIMENl); zero_ld(b,DIMEN2);

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 133

zero_ld(x,DIMENl); zero_ld(y,DIMEN2); zero_ld(nevvecl,DIMENl); zero_ld(newvec2,DIMEN2);

/* NOW 2-DIMENSIONAL VECTORS, WHICH WILL BE TREATED LIKE 1-D VECTORS */ d2 = DIMEN1* DIMEN2; zero_ld(xty,d2);

}

SIEVE86.ASM Accompanies "The Kaypro 386" by Ray Duncan, BYTE, September 1987.

Title "Eratosthenes Sieve for 80x86 Real Mode" Name Sieve Page 50,132

; Eratosthenes Sieve for 80x86 Real Mode ; Implemented by Ray Duncan, April 1987 ; After Gilbreath, BYTE, September 1981 and January 1983

niter

equ

100

; number of iterations

asize

equ

8190

; size of array "flags"

cr

equ

Odh

; ASCII carriage return

If

equ

Oah

; ASCII linefeed

stdin

equ

0

; handle for standard input

stdout

equ

1

; handle for standard output

.TEXT

segment para public 'CODE'

assume cs:_TEXT,ds:_DATA,es:.DATA

sieve

proc

near

mov

ax,seg JDATA

mov

ds,ax

mov

es,ax

mov

dx,0

; convert number of iterations

mov

ax,niter

mov

cx,10

mov

si, off set msgla+3

call

blnasc

mov

dx,offset msgl

; display message

mov

cx,msgl_len

; "StartingN iterations of Sieve

call

pmsg

call

getmsec

; get current time in msec

push

dx

; and save it ...

push

ax

mov

counter,niter

; initialize iterations counter

slevel:

mov

di, off set flags

; a sieve iteration starts here.., ; initialize flags array

mov

cx,asize

; to all bytes « TRUE

mov

cld

rep stosb

al,l

xor

si,si

; SI ■ index to flags array

xor

di,di

; DI = primes counter

sieve2:

test

byte ptr flags [ s i ], 1

; main loop of sieve ; is this a prime?

Jnz

short sieve4

; Jump if prime

Table caption134 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

sieved: inc

si

; bump to next slot in "flags"

emp

si,asizc

; are we done?

Jle

sieve2

; Jump to test another

dec

word ptr counter

; more iterations?

Jnz

sievel

; jump, another iteration needed

Jmp

sleve7

sieve4:

bx,sl

; prime found, zap its multiples

mov

; copy i

mov

dx,bx

; DX = prime = i + i + 3

add

dx,dx

add

dx,3

xor

al,al

Jmp

short m1ovo6

sieve5: mov

by to ptr flags|bx],al

; zero this multiple

sieve6: add

bx,dx

; find next multiple of prime

emp

bx,a«lse

; have we exhausted the array?

Jle

slovo^

; not yet, zap it

inc

di

; count primes and try next

Jmp

siev#3

sieve7:

; done with all iterations...

call

gotmaoo

; get current time

push

dx

; and save it...

push

ax

mov

ax,dl

; convert number of primes

mov

dx,0

mov

ox ,10

mov

offset msg/aU

call

blntso

mov

dx, offset m«g;’

; display "Number of primes:"

mov

ox, mug.* Ion

call

pm««

pop

ax

; stop time: low word

pop

dx

# high word

pop

bx

; start time: low word

pop

ox

# high word

sub

ox,bx

; DX:AX = stop - start

sbb

dx,ox

mov

ox,niter

i divide by number of iterations

idiv

ox

mov

dx,0

; convert msec to ASCII

mov

ox, 10

mov

si, offset mug la»4

call

blneso

mov

dX,Off set msg I

; display "Elapsed time:"

mov

ox,magi l«n

call

pm«|

mov

nx, 040001)

; exit to DOS with

int

2111

; return code = 0

sieve endp

getmsec proo

near

; DX : AX : = current time in msec.

mov

nli,2oh

i read time from MS-DOS

lnt

21h

push

dx

; save seconds, hundredths

mov

«l, <ili

; AX : = hours

cbv

mov

bx,60

; hours -> minutes

lmul

bx

xor

oh, eh

; Isolate system minutes

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 135

add

ax,cx

; and find total minutes

mov

bx,60

; minutes -> seconds

imul

bx

pop

CX

; recover seconds, hundredths

mov

bl,ch

; get seconds

xor

bh,bh

add

ax,bx

; find total seconds

adc

dx,0

; carry if necessary

xor

ch,ch

; save centisec.

mov

bp,cx

; total seconds * 100 the hard way

mov

bx,ax

; double multiply # 10

mov

cx,dx

add

ax, ax

; *2

adc

dx,dx

add

ax, ax

; *4

adc

dx,dx

add

ax,bx

; * 5

adc

dx,cx

add

ax, ax

; * 10

adc

dx,dx

mov

bx,ax

; double multiply * 10

mov

cx,dx

add

ax, ax

; *2

adc

dx,dx

add

ax, ax

; *4

adc

dx,dx

add

ax,bx

; *5

adc

dx,cx

add

ax, ax

; * 10

adc

dx,dx

add

ax, bp

i add in hundredths of seconds

adc

dx,0

; now convert total to msec.

mov

bx,ax

; double multiply # 10

mov

cx,dx

add

ax, ax

; * 2

adc

dx,dx

add

ax, ax

• *4

adc

dx,dx

add

ax,bx

; * 5

adc

dx,cx

add

ax, ax

; * 10

adc

dx,dx

ret

; return DX:AX = msec.

getmsec endp

; BINASC: Convert 32-bit binary value to ASCII string.

; Call with DX:AX = signed 32-bit value ; CX - radix

} SI = last byte of area to store resulting string

; (make sure enough room is available to store the string in the radix you have selected.)

; Destroys AX, BX, CX, DX, and SI.

binasc

proc

near

; convert DX:AX to ASCII.

mov

byte ptr [si], 'O'

; force storage of at least one digit

or

dx,dx

; test sign of 32-bit value,

pushf

; and save sign on stack.

Jns

binl

j Jump if it was positive.

not

dx

; negative, take 2's complement

not

ax

; of the value.

add

ax,l

adc

dx,0

binl:

j divide 32-bit value by radix

; to extract next digit for the

; forming string.

mov

bx,ax

; is the value zero yet?

or

bx,dx

136 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

Jz

bin3

call

divide

add

bl,'0»

cmp

bl,'9'

Jle

bin2

add

bi/A’-'g’-i

bin2:

mov

[si],bl

dec

Ml

Jmp

binl

bin3:

popf

jns

bln4

mov

byte ptr [si],

bin4:

ret

binasc

endp

; yes, we are done converting.

; no, divide by radix.

; convert remainder to ASCII digit. ; might be converting to hex ASCII,

; Jump if in range 0-9,

; correct it if in range A-F.

; store this character into string. ; back up through string,

; and do it again.

; restore sign flag,

; was original value negative?

; no, Jump

; yes, store sign into output.

; back to caller.

General-purpouo hi I by If.-bit unsigned divide.

This must be usod In..I..I r l.ho plain machine unsigned divide for cases where the quotient may overflow 16 bits

(for example, dividing 100,000 by 2). If called with a zero divisor, this routine returns the dividend unchanged and gives no warning. B

Call with DX:AX « hit dividend CX • dlvl 101

Table captionReturns DX:AX ■ •lUotlmit

i

BX

■ romnlnder

i

i

CX

■ divisor (unchanged)

divide

proc

near

; Divide DX:AXby CX

Jcxz

dlvl

; exit if divide by zero

push

nx

i 0:dividend_upper/divisor

mov

nx, dx

xor

dx,dx

div

ox

mov

bx,nx

; BX = quotientl

pop

AX

; remainderl:dividend_lower/divisor

div

ox

xchg

bx,ilx

; DX:AX = quotientl:quotient2

divl:

ret

i BX ■ remainder2

divide

endp

pmsg

proc

near

j print a message on std output

; call with DS.-EDX = address

l ECX = length

mov

Ahi40lt

mov

bx,«tdout

int

21h

ret

pmsg

endp

_TEXT

ends

_DATA

segment |»u « pub Mo ’DATA'

flags

db

amImi | dup (7)

counter

dw

r

msgl

db

•»•'# If i '(lUrtlng '

msgla

db

! Urntloiwi of Sieve... ' ,cr,lf

msgl_len equ $

magi

msg2

db

"i » 1 ('i ’l‘rl m« n found: '

msg2a

db

* »,or,lf

msg2_len equ $

flllgtl

msg3

db

Oi'ilf, 'llnpned tlmo: •

msg3a

db

roaeo, per i teration

1 >cr,lf

msg3_len equ t

meg l

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 137

.DATA

ends

.STACK

segment byte stack 'stack

db

4096 dup (?)

.STACK

ends

end

sieve

TURBFLOP.PRO Contributed by Alex Lane. From "ALS Prolog,” BYTE, September 1987.

/* Floating-Point Test Program */ /* */ /# written in Turbo Prolog #/

/* 6-10-87 a.lane */

/* */ /# result for 5000 repetitions: */ /# 30 seconds */

predicates

float_point time_l( integer ) cycle( integer, real, real, real ) calc( real, real, real, real )

goal

float_point.

clauses

float_point

write( ’'Enter number of repetitions: " ), readint( Iters ), time_l( Start),

cycle( Iters, 1.0, 2.71828, 3.1*159 )i time_l( Finish ),

Overall = Finish - Start, write( "Time is " ), write( Overall) ,nl.

calc( C,CF,A,B )

Cl = C # A,

C2 = Cl # B,

C3 = C2/ A,

CF = C3 / B.

cycle( 0,C,_,_)

write( "C is " ), write(C ),nl.

cycle( N,C,A,B )

ealc(C,CF,A,B),

N1 = N - 1, oyole(Nl,CF,A,B).

time_l( Time )

/# quick and dirty; won't work across midnight *1 /# and ignores hundreths of a second #/

time( H,M,S,_ ),

Time = S + 60 ^ (M + 60*H).

KAREX2.BAS Accompanies the article "Karmarkar's Algorithm" by Andrew M. Rockett and John C. Stevenson, BYTE, September 1987.

100 • 101 '

102 ' KAREX2.BAS is a Microsoft BASIC Release 5 program

103 * that solves EXAMPLE 2 of the article

104 •

105 ’ KARMARKAR' S ALGORITHM

L

138 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

106 '

107 * by Andrew M. Rockett and John C. Stevenson

108 •

109 ’ This program was written by Andrew M. Rockett

110 '

111 '..

200 '

202 ' N is the number of unknowns and K is the number of equations 204 *

206 N = 8 : K = 4 208 •

210 K1 = K + 1 : K2 = 2*K1

212 DIM A0(N), X0LD(N), XNEW(N), CC(N), CP(N),

A(K,N), B(K1,N), B1(K1,K2), B2(N,K1), B3(N,N)

214 FOR C = 1 TO N : A0(C) = 1/N : XNEW(C) = A0(C) :

NEXT C 216 »

218 ' T is the tolerance 220 ■

222 T = .001 224 '

226 ' ALPHA is usually set equal to 1/4 ...

228 '

230 ALPHA = .25 232 •

234 ITERATION = 0 236 '

238 ' Data for constraint matrix A 240 '

242 DATA 1, 0, 1, 0, 0, 0, 1, -3 244 DATA 1, 0, 0, -1, 0, 0, 2, -2 246 DATA 0, 1, 0, 0, 1, 0, 3, -5 248 DATA 0, 1, 0, 0, 0, -1, 4, -4 250 1

252 FOR R = 1 TO K : F0RC = 1T0N : READA(R,C) :

NEXT C : NEXT R 254 '

256 * Data for objective function CC 258 '

260 DATA 0, 0, 0, 0, 0, 0, 1, 0 262 '

264 FOR C « 1 TO N : READ CC(C) : NEXT C 266 •

268 V = 0 : FOR C«1 TO N : V = V + CC(C)*A0(C) :

NEXT C : VNEW = V 270 '

272 ' Main iteration process is the same as in KAREX1.BAS ...

274 '

300 WHILE VNEW/V>T

301 PRINT USING "HHH "; ITERATION;:

FOR C«1 TO N: PRINT USING "M#. MM";XNEW(C); :

NEXT C : PRINT USING "MM.MMM#";VNEW/V

302 ITERATION = ITERATION + 1

303 FOR C - 1 TO N : XOLD(C) =» XNEW(C) ; NEXT C

304 FOR R=1 TO K: FOR C=1 TO N:B(R,C)=A(R,C)#XOLD(C):

NEXT C: NEXT R

305 FOR C=1 TO N:B(K1,C)*1;NEXT C

306 FOR R=1 TO K1 : F0RC=1T0K2 : B1(R,C)=0 :

NEXT C : NEXT R

307 FOR R-l TON : F0RC*1T0K1 : B2(R,C)=0 :

NEXT C : NEXT R

308 FOR R=1 TO N : FOR CHITON : B3(R,C)*0 :

NEXT C : NEXT R

309 FOR C-l TO N : CP(C) » 0 : NEXT C

310 FOR R=1 TO Kl: FOR C=1 TO Kls

FOR 1=1 TO N:B1(R,C)=B1(R,C)+B(R,I)#B(C,I):

NEXT I:

NEXT C: NEXT R

311 FOR I = 1T0K1 : B1(I,I+K1)*1 : NEXT I

312 FOR R = 1 TO Kl

313 IF B1(R,R) <>0 THEN 318

314 I - R + 1

315 IF I > Kl THEN PRINT 'Error! BBT is SINGULAR!' ;

GOTO 407

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 139

316 IFBl(I,R) = 0THEN 1*1+1: GOTO315

317 FOR C = 1 TO K2 : SWAP B1(R,C),B1(I,C) : NEXT C

318 FOR I = R+l TO K1:Z = Bl(I,R)/Bl(R,R):

FOR C=1 TO K2:Bl(I,C)=Bl(I,C)-Z*Bl(R,C):NEXT C:

NEXT I

319 NEXT R

320 FOR R=K1 TO 2 STEP -1:FOR I = R-l TO 1 STEP -1:Z = Bl(I,R) /B1(R,R): FOR C=R TO K2:B1(I,C)=B1(I,C)-Z#B1(R,C):NEXT C:

NEXT I:NEXTR

321 FOR R=1 TO K1:Z = B1(R,R):

FOR C=1 TO K2:B1(R,C)=B1(R,C)/Z:NEXT C:

NEXT R

322 FOR R=1 TO N: FOR C=1 TO K1:

FOR J=1 TO K1:B2(R,C)=B2(R,C)+B(J,R)#B1(J,C+K1):

NEXT J:

NEXT C: NEXT R

323 FOR R=1 TO N: FOR C=1 TO N:

F0RJ=1T0K1:B3(R,C)=B3(R,C)+B2(R,J)*B(J,C):

NEXT J:

NEXT C: NEXT R

324 FOR R = 1 TO N : B3(R,R) = B3(R,R) -1 : NEXT R

325 FOR R=1 TO N:FOR C=1 TO N:B3(R,C)=-1*B3(R,C):

NEXT C: NEXT R

326 FOR R=1 TO N:FOR C=1 TO N:B3(R,C)=B3(R,C)*XOLD(C):

NEXT C: NEXT R

327 FOR R=1 TO N:FOR C=1 TO N:CP(R)=CP(R)+B3(R,C)*CC(C):

NEXT C: NEXT R

328 AA=0:F0R C=1 TO N : AA = AA + CP(C)#CP(C) : NEXT C

329 AA = SQR( AA) : FOR C=1 TO N : CP(C) * CP(C) / AA :

NEXT C

330 AA = SQR(N#(N-l)) / ALPHA

331 FOR C=1 TON : XNEW(C) * (A0(C) - CP(C)/AA)*XOLD(C) :

NEXT C

332 AA=0:F0R C=1 TO N : AA = AA + XNEW(C) : NEXT C

333 FOR C=1 TO N : XNEW(C) = XNEW(C)/AA : NEXT C

334 VNEW=0: FOR C=1 TO N: VNEW=VNEW+CC(C)»XNEW(C) :NEXT C

335 WEND

336 »

400 PRINT:PRINT*Tolerance reached: Vnew/Vinltial =

VNEW/V:PRINT

401 PRINT USING "W; ITERATION; :

FOR C=1 TO N:PRINT USING **M0.MM";XNEW(C); : NEXT C :

PRINT USING *'; VNEW/ V

402 '

403 ' Project solution from simplex back to orthant ...

404 *

405 PRINT: FOR C=1 TO N-2:PRINT XNEW(C)/XNEW(N), : ■

NEXT C: PRINT

406 »

407 END

KAREX1.BAS Accompanies the article "Karmarkar's Algorithm*' by Andrew M. Rockett and John C. Stevenson, BYTE, September 1987.

100

101

102

103

104

105

106

107

108

109

110 111 200 202 204

KAREX1.BAS is a Microsoft BASIC Release 5 program that solves EXAMPLE 1 of the article

KARMARKAR'S ALGORITHM by Andrew M. Rockett and John C. Stevenson This program was written by Andrew M. Rockett

N is the number of unknowns and K is the number of equations

206 N » 3 : K « 1 208 '

210 K1 = K + 1 : K2 « 2#K1

140 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

212 DIM AO(N), XOI.D(N), XNKW(N), CC(N), CI>(N), A(K,N), B(K1,N), B1(K1,K2), B2(N,K1), B3(N,N)

214 1

216 ' CC is for tho objootlvo (‘unction 218 ' Bl, B2 and B3 ore uaod for tho computation of CP 220 1 R and C are "row" and "column" Indices 222 »

224 ' Initially, sotXNcw AO, the 'Utor of simplex 226 •

228 FOR C = 1 TO N: A0(C) 1/N : XNFW(C) - A0(C) : NEXT C

230 »

232 ' T is the toloranoo 234 •

236 T= .001 238 '

240 ' ALPHA is usuii I ly riM nqun I to 1 , ; 4 .,.

242 r

244 ALPHA => .25 246 '

248 ITERATION - 0 250 '

252 r Data for count mint mat 1 I« A 254 •

256 DATA 2, -3, 1 258 '

260 FOR R ■ 1 TO K : I < )H r I I D N I FAD A(R,C):NEXT C:NEXT R 262 »

264 » Data for object lv.« (’»»»».' 1 l.-n n:

266 '

268 DATA 3, 3, I 270 •

272 FORC ■ 1 TO N : HI AIM r(t ) ; NI X 1 (

274 •

276 ' Set initial Value ti» vuhie »»i cantor of simplex ...

278 '

280 V = 0 : FOR C 1 TON V V • (Mi - •» A()( C) jNEXTC: VNEW = V 282 »

284 • Now wo can bry in tlmMAIN I i I J j A r ION process ...

286 '

300 WHILE VNEW/V > T

301 '

302 PRINT USING "NNMH" * I l HtA M<>ii, M >k ( -1 TO N: PRINT USING EW(C); : NEXT C : PRINT USING NEW/V

304 ITERATION ITI'RAI MN . 1

305 '

306 ' Put Xnow 1|<M X..M

307 '

308 FOR C ■ 1 TON l Xol,|»( 1 > XN! Wh ) : NEXTC

309 ’

310 ' Construct, 1 lm mat. 1 ■ n

311 '

312 FOR R*1 TO K 1 1'Olt ( I I'm N |ur,< ) A(R,C)#X0LD(C) : NEXT C : NEXT R

313 FOR C l TON IM K I .<• I 1 hi ■

314 •

315 ' Zero inatrliuiN !.m lm nmni ... u tot ions...

316 •

317 FOR IM TO HI FOlK'-l M h.' IU(R,C)-0 : NEXT C : NEXT R

318 FOR R-l TO N !<>IH l MM 1 '(It ,C) -0 : NEXT C : NEXT R

319 FOR R-I TON I m|i 1 1 111 n in < It , 0 ) 0 : NEXT C : NEXT R

320 FOR C-l TON ' Id ) 0 HI-HI

321 '

322 ' Find BUT ami | 'ii in n 1

323 1

324 FOR H - II" » 1 1 - -Mmm mum 1 TO N:B1(R,C)=B1(R,C)+B(R, I)#B(C, I): NEXT I: NEXT C : NEXT R

325 ’

326 • Adjoin an l.i. 1 • 1 * .. . 1 .

327 '

328 FOR I - I TO X I i«l( 1 , hi 1 ) l ni-.X'l I

329 '

330 ' Row reduce nit 1 1 1

331 '

332 FOR R - I MM

333 IF Bl(Rfli) • • II I III 1 N l IM

334 I - R • I

335 IF I > M 'IIll'll 1 hi 111 "I ri'Mfl hill In !NGULAR!": GOT0 400

336 IF III(1 ,10 1 Mill'll I •• 1 1 1 mu 135

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987 141

Chapter Notes

DEFINITION MODULE SortElemType;

(* This module is intended to describe the elements to be sorted # as an abstract data type.

*)

EXPORT QUALIFIED ElemType, compare, select, optionMenu, ReadArray, WriteArray;

ElemType;

PROCEDURE compare (x, y: ElemType): BOOLEAN;

(* compare(x,y) implements: x< y

defined as NOT (y <* x), for ascending order; and if descending order is desired compare(x,y) should implement: x > y

defined as NOT (x <* y);

where "<=" denotes a binary relation that must satisfy the total order properties:

1. x<* x

2. x < = y ANDy <= x ==> x = y

3. x<= y ANDy<* z ==> x<= z

4. x<=yORy<=x for every x, y *)

September

337 FOR C * 1 TO K2 : SWAP B1(R,C) ,B1(I,C) : NEXT C

338 FOR I « R+l TO K1 : Z = B1(I,R)/B1(R,R): FOR 0*1 TO K2:Bl(I,C)sBl(I,C)-Z*Bl(R,C): NEXT C:NEXT I

339 NEXT R

340 »

341 ' Now back substitute to finish it ...

342 '

343 FORR » K1 TO2STEP-1 : FOR I - R-lTO 1 STEP-1 : Z ■ B1(I,R)/B1(R,R) s FOR C = R TO K2:B1(I,C)=B1(I,C)-Z*B1(R,C): NEXT C: NEXT I :NEXT R

344 '

345 Remember to make diagonal entries l's

346 '

347 FORR=1 TO K1 : Z - B1(R,R) : F0RC-1T0K2 : B1(R,C) ■ B1(R,C)/Z : NEXT C : NEXTR

348 »

349 ' BBT Inverse is now in B1 in columns Kl+1 to K2

350 '

351 ' Now multiply BBT Inverse by BT and put in B2

352 '

353 FOR R * 1 TO N : F0RC-1T0K1 : FOR J * 1 TO K1:B2(R,C)=B2(R,C)+B(J,R)*B1(J,C+K1) :NEXT J:NEXT C : NEXT R

354 •

355 ' Take THAT and multiply by 3 and put in B3

356 •

357 FOR R * 1 TO N : FOR C * 1 TO N : F0RJ*1T0 K1:B3(R,C)«B3(R,C)+B2(R, J)*B(J,C) :NEXT J:NEXT C : NEXT R

358 '

359 ' Find I-B3 by subtracting l's on diagonal and changing signs 361 '

362 FOR R = 1 TO N : B3(R,R) * B3(R,R) - 1 : NEXT R

363 FOR R-l TO N: FOR C-l TO N:B3 (R, C) = -1*B3(R,C):NEXT C: NEXT R

364 »

365 ' Multiply by D

366 '

367 FOR R«1T0N:F0RC»1T0N:B3(R,C)=B3(R,C)*X0LD(C):NEXT C:NEXT R

368 '

369 ' Find projection of CC and call it CP

370 '

371 FOR R-l TO N: FOR C-l TO N:CP(R)«CP(R)+B3(R,C)*CC(C):NEXT C:NEXT R

372 '

373 ' Find length of CP and the normalized CP

374 »

375 AA = 0

376 FOR C-l TO N : AA * AA + CP(C)*CP(C) : NEXT C

377 AA » SQR(AA) : F0RC=1T0N : CP(C) *CP(C)/AA : NEXT C

378 '

379 'Find a*, project back to get new X ...

380 '

381 AA = SQR(N*(N-1))/ALPHA

382 FOR C-l TON : XNEW(C) « (A0(C) - CP(C)/AA)*XOLD(C) : NEXT C

383 '

384 ' And remember to divide by "size" of new X to complete the projective transformation

385 ' back to the original simplex

386 '

387 AA = 0

388 FOR C*1 TO N : AA = AA + XNEW(C) : NEXT C

389 FOR C-l TON : XNEW(C) =XNEW(C)/AA : NEXT C

390 '

391 ' Find objective function Value at NEW point X

392 ’

393 VNEW = 0

394 FOR C=1 TO N : VNEW = VNEW + CC(C)*XNEW(C) : NEXT C

395 '

396 WEND ' End of main iteration loop ...

397 '

398 PRINT:PRINT"Tolerance reached: Vnew/Vinitial = VNEW/V:PRINT

399 PRINT USING "M##" j ITERATION; : FOR C*1 TO N: PRINT USING "###.####" ;XNEW(C); : NEXT C : PRINT USING "WM.UmU"', VNEW/V

400 END

142 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

BBS’S POSTING BYTENET LISTINGS

Australia:

Grayham Smith 12 Brentwood Road Flinders Park, South Australia 5025 The Electronic Oracle 300 Baud, CCITT Standard Telephone: 08-43-3331 Vbice 08-260-6686 BBS

Edward A. Romer 31 Warwick Street Killara,

Sydney NSW. Australia 2071 OMEN

300 & 1200 Baud Telephone: 02-498-2399 Voice (Work)

02-499-2642 Voice (Home)

02-498-2495 BBS

Alan Salmon PCUG Sysop GPO Box 2229 Canberra.

A.C.T, 2601. Australia Canberra PC Users Group Inc.

300 & 1200 Baud Telephone: 61-62-58-9967 BBS

Angus S. Bliss POB 293

Hamilton NSW 2303, Australia

Newcastle Microcomputer Club

300 Baud. CCITT Standard, 8 Bits, 1 Stop. No Parity

Telephone: 049-67-2433 Voice (Angus Bliss)

049-54-9505 Voice (Tony Nicholson) 61-49-685385 BBS

John Hastwell-Batten POB 242

Dural, NSW 2158, Australia Tesseract RCPM+

300 Baud. CCITT Standard. 8 Bits. No Parity Telephone: 02-651-2363 Voice 02-651-1404 BBS

Phil Harding POB 35

Charnwood A.C.T.. Australia 2615 PC-Exchange Bulletin Board 300 & 1200 Baud, CCITT Standard Telephone: 61-062-581406 Vbice 61-62-586352 BBS

Eric Salter POB 60

Canterbury 3126. Australia

MICOM: The Microcomputer Club of Melbourne

300 Baud

Telephone: 61-3-861-9117 Eric Salter

61-3-762-1386 Peter Jetson (SYSOP) 61-3-762-5088 BBS

Craig Bowen

29 Warrigal Road

Surrey Hills 3127, Vic., Australia

Public Resource HI

300 Baud. CCITT Standard. 8 Bits, 1 Stop. No Parity Telephone: 03-890-2174

John Blackett-Smith Unit 8

69 Wattle Road Hawthorn 3122, Australia The National Fido Telephone: 613-818-2336

Austria:

Wotfpng Hryzak 3ahnstrasse 48 X-2230 Gansemdorf. Austria 1 lersin of Vienna BBS FIDO 300 Baud. 8 Bits. 1 Stop Bit Tdephooe: 02282-24094 BBS

Brazil:

Stsiema Sampa ATTN Rizieri Maglio R Bxtugal. 202 Jdm Europe - CEP 01446 Sao Paulo - SP - Brazil Sisiema Sampa

} X L . 200 Baud. CCITT Standard Tekphooe: 011-8536273 BBS

Canada:

Leigh Calnek 3036 25th Avenue

Rei.ru. Saskatchewan, Canada S4S 1K9 Telephone: 306-586-9253 BBS

Torn Kashuba

PCOMM Systems

:-l 1 Fort Street, Suite 2001

Montreal, Quebec. Canada H3H 2N7

Telephone: 514-989-9450 BBS

Gary McCallum

Western Canadian Distribution Center 3420 48th Street

Edmonton. Alberta. Canada T6L 3R5 300 & 1200 & 2400 Baud Telephone: 403-462-9189 Voice 403-461-9124 BBS

Judson Newell

Canada Remote Systems

Suite 311,4198 Dundas Street West

Toronto. Ontario. Canada M8X 1Y6

Telephone: 416-231-2383 Voice

416-231-9202 BYTEnet System

Vernon Paige EPSNUNK 3 McNicoll Avenue

Willowdale. Ontario. Canada M2H 2A6 300 & 1200 Baud Telephone: 416-494-1380 Voice 416-635-9600 BBS

Terry Smythe Sysop, Z-Nodc 40 Muddy Water User Group 55 Rowand Avenue

Winnipeg, Manitoba, Canada R3J 2N6 Telephone: 204-832-3982 Vbice 204-945-6713 Voice 204-832-4593 BBS

Chile:

Eurique Benavides Z.

Guillermo Gomara C.

Eliodoro Yanez 2210 Providencia Santiago de Chile BIGSA BBS

2400/1200 300 Bell & CCITT Telephone: 562-49*4$

10:00 am to 4 00 am Clfekaa^me* Downloads & Uploads Xmodem ASCII

Denmark:

Beverly Kleiman International Representative Personal Computer Society of Denmark Kronprinsensgade 14,

DK-1114 Copenhagen, Denmark 300 Baud. CCITT Standard Telephone: 01-122518 BBS

England:

Frank Thornley 67 Woodbridge Road.

Guildford,

Surrey GU21 UP. United Kingdom CompuLink

Telephone: 0-483-65895 Vbice

0-483-573337 (300/1200 Baud) BBS 0-483-573338 (1200/2400 Baud) BBS

Finland:

Juha Wiio Databox Oy Museokatu 11 00100 Helsinki. Finland DATABOX FIDO 300 & 1200 Baud Telephone: 358-0-497904

Vivian Ronald Dwight Suvikuja 3 B 14 02120 Espoo. Finland Micro Maniacs III Fido Node 17 300 & 1200 &. 2400 Baud Telephone: 358-0-424524 Vbice 358-0-4557307 Voice 358-0-467673 BBS

France:

Bill Graham.

President

OUF! (Ordinateurs Utilisateurs France)

ATTN: OUFLOG. B P. 62 10 rue Saint Nicolas 75012 Paris, France 300 Baud. CCITT Standard Telephone: 331-43-44-06-48 Vbice (Bill) 331-43-44-82-65 Vbice 331-43-41-61-47 OUFLOG for BYTE Listings 331 -43-40-33-79 OUFTEL 300 & 1200 Baud 331 -43-07-95-39 OUFTEL

Dr. Bernard Pidoux

Groupe Des UtUisaicurs Francophones D Tnformatique

37. Boulesard Samt-Jacques

750U Pans. France

300 Baud. CCITT Standard

Telephone 1-47-63-72-50 Vbice

1 -45-65-10-09 GUFINET 1-45-65-10-11GUFITEL

Hong Kong:

W A Hanafi SEAnet

Suite 812. Star House.

Tsim Sha Tsui. Kowloon. Hong Kong ATTN: Christine Wong Telephone: 5-455088 Vbice

5-8937856 SEAnet 1 5-724495 SEAnet 2

continued

BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1987 143

Indonesia:

James D. Filgo

US Embassy Box R

APO SF 96356-5000

Jakarta Computer Society

300 Baud. Bell & CCITT Standard

Telephone: 062-21-799-3286 BBS

Israel:

Zohar Levitan POB 10279 Tshala 61102 Israel

(Contact for telephone number)

Ireland:

Gerry Clarke 30 Auburn Road

Dunlaoire County. Dublin, Ireland Dublin Bax Bulletin Board 300 & 1200 Baud Telephone: 353-01-854179

Italy:

Bruno Bonino MICRO design s.r.l.

Via Rostan, 1 16155 Genova, Italy C.B.B.S.

CCITT & Bell Standard Telephone: 10-687098 Voice 10-688783 BBS

Giorgio Leo Rutigliano Via degli Oleandri, 7 POB 175

85100-Fotenza, Italy

FIDO-PZ

300 Baud

Telephone: 0971-34593 Voice (Work)

0971-54431 Voice (Home) 0971-35447 BBS

Claudio Vandelli Amministratore Unico SOFT SERVICE s.r.l.

ViaG. B. Morgagni 32 20129 Milano, Italy SOFT SERVICE BBS

300 Baud, CCITT Standard. 8 Bits, No Parity, Duplex

Telephone: 02-209231 Voice 02-228467 BBS

Paolo Marraffa Computronix Via De Amicis 76 90145 Palermo, Italy Network Computer Club

300 Baud, CCITT Standard. 8 Bits, 1 Stop Bit, Duplex

Telephone: 39-91-266021 BBS 39-91-300229 BBS

Japan:

Peter Perkins Vice President

Honda Trading Company Ltd.

Mail 101

9-91-Chome, Sota Kanda Chiyoda-ku, Tokyo, Japan JAN/S

300 & 1200 Baud. CCITT Standard Telephone: 03-251-0855 BBS

Malaysia:

Ong Boo Huat 3. Jalan Pi sang

Jalan Kelang Lama. 58000 Kuala Lumpur

STARUNK

300 Baud

Telephone: 03-7578811 X 116 Vbice 03-7576644 BBS

Nigeria:

Chester W. Vlaun MTCE/31 POB 263

Port Harcourt. Nigeria, West Africa 300 Baud

Telephone: 234-84-301210 to 301229-3022

Norway:

Robert Hertz Hertz Data Inc.

Huitssfeldts Gate 16 N-0253 Oslo, Norway Hacker s Unlimited Telephone: 47-2-431655 Voice 47-2-390521 BBS

Helge Vindenes 5670 FUSA, Norway Costa del

Telephone: 47-5-151610 Vbice 47-5-234129 BBS

Saudi Arabia:

Larry Layland System Operator DPCS Aramco Box 10063

p u j] Dhahran, Saudi Arabia 31311

Dhahran Personal Computing Society Bulletin Board Telephone: 03-873-7851 BBS

Singapore:

Ken Ong

10 Orange Grove Road *04-01

Singapore 1025, Singapore K B B S

Fu ll 300 & 1200 Baud

Telephone: (IDD) 65-734-5825 Voice (IDD) 65-737-4090 BBS

Sweden:

Jacob Palme

Stockholm University Computer Centre-QZ Box 27322

102 54 Stockholm, Sweden BYTECOM

Telephone: 46-8-65-45-00 Voice (Work)

08-23-86-60 (300 Baud)

08-23-89-30(300 Baud)

08-15-59-20(300 Baud) 08-14-35-00(1200 Baud) 08-22-81-30(1200 Baud) 08-24-61-20(1200 Baud) 08-14-53-70(1200 Baud)

Carl Nordin

Nyakersgatan 8B

531 41 Lidkoping, Sweden

A.T.L

300 & 1200 Baud. CCITT Standard Telephone: 46-510-25280 Vbice 46-510-20409 BBS

Switzerland:

Peter M. C. Werner 9, rue de la Colombiere 1260 Nyon, Switzerland OCTET

300 & 1200 & 2400 Baud, CCITT Standard Telephone: 41-22-62-16-54 Voice 41-22-62-18-17 BBS

Albert F. Sluder Technical Director Kupfer Electronic AG Soodstrasse 53

Fostfach, 8134 Adliswil, Switzerland TRAX

300 Baud, CCITT Standard Telephone: 01-710-81-11 Vbice 01-710-44-36 BBS

The Netherlands:

Henk Wevers

Cloeckendaal 38

6715 GH Ede, The Netherlands

Henk Wevers ’ Fido

Telephone: 31-8380-37156 BBS

West Germany:

Rupert Mohr

RMI Nachrichtentechnik GmbH RosstraBe 7 Postfach 1526

D-5100 Aachen, West Germany RMI Net

Telephone: 49-241-21145 Vbice

45-2410-90528 BYTEnet - DATEX-P 0-26245-2410-90528 User Data - DATEX-P

Rudolf Strieker Unsoeldstr. 20

D-8000 Munich 22, West Germany T-BUS FIDO

Telephone: 089-29-38-81 BBS

144 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER, 1987

Announcing BYTE’s New Subscriber Benefits

Y

Xoi

Program

.our BYTE subscription brings you a complete diet of the latest in microcomputer technology every 30 days. The kind of broad-based objective coverage you read in every issue. In addition, your subscription carries a wealth of other benefits. Check the check list:

DISCOUNTS

13 issues instead of 12 if you send payment with subscription order.

One-year subscription at S21 (50% off cover price).

Two-year subscription at S38.

Three-year subscription at S55.

Ef One-year GROUP subscription for ten or more at S17.50 each. (Call or write for details.)

SERVICES

si BIX: BYTE’s Information Exchange puts you on-line 24 hours a day with your peers via computer conferencing and electronic mail. All you need to sign up is a microcomputer, a modem, and telecomm software.

Reader Service: For information on products advertised in BYTE, circle the numbers on the Reader Service card enclosed in each issue that correspond to the numbers for the advertisers you select. Drop it in the mail and we’ll get your inquiries to the advertisers.

(jj TIPS: BYTE’s Telephone Inquiry System is available to

EVTE

subscribers who need fast response. After obtaining your Subscriber I.D. Card, dial TIPS and enter your inquiries. You’ll save as much as ten days over the response to Reader Service cards.

Disks and Downloads:

Listings of programs that accompany BYTE articles are now available free on the BYTEnet bulletin board, and on disk or in quarterly printed supplements.

^ Microform: BYTE is available in microform from University Microfilm International in the U.S. and Europe.

BYTE's BOMB: BYTE s Ongoing Monitor Box is your direct line to the editor's desk. Each month, you can race the articles via the Reader Service card. Your feedback helps us

keep up to date on your information needs.

Customer Service: If you have a problem with, or a question about, your subscription, you may phone us during regular business hours (Eastern time) at our toll-free number: 800258-5485. You can also use Customer Service to obtain back issues and editorial indexes.

BONUSES

Annual Separate Issues: In addition to BYTE’s 12 monthly issues, subscribers also receive our annual IBM PC issue free of charge, as well as any other annual issues BYTE may produce.

^ BYTE Deck: Subscribers receive five BYTE postcard deck mailings each year—a direct response system for you to obtain information on advertised products through return mail.

To be on the leading edge of microcomputer technology and receive all the aforementioned benefits, make a career decision today. Call toll-free weekdays, 8:30am to 4:30pm Eastern time: 800-258-5485.

And. . . welcome to BYTE country!

BITE

THE SMALL SYSTEMS JOURNAL

m

Borland’s new TUrbo C:

The most powerful optimizing compiler ever

O ur new Turbo C generates fast, tight, productionquality code at compilation speeds of more than 13,000* lines a minute!

It’s the full-featured optimizing compiler everyone has been waiting for.

Switching to TUrbo C, or starting with TUrbo C, you win both ways

If you’re already' programming in C, switching to Turbo C will make you feel like you’re riding a rocket instead of pedaling a bike.

If you’ve never programmed in C, starting with Turbo C gives you an instant edge. It’s easy to learn, easy to use, and the most efficient C compiler at any price.

6 6 Turbo C does look like What We’ve All Been Waiting For: a full-featured compiler that produces excellent code in an unbelievable hurry... moves into a class all its own among fullfeatured C compilers ... Turbo C is indeed for the serious developer ... One heck of a buy—at any

price. Michael Abrash,

Programmer's Journal J /

Join more than 100,000 Turbo C enthusiasts. Get your copy of Turbo C today!

A. Borland products are trademark* or registered trademarks o» Borland internatonat. me. or Bor and Anayica. tnc Ott* Orard and product names are trademarks or registered trademarks oi me* respect* riders Copyright 1987 Borand Internationa BM136

For the dealer nearest you or to order by phone call

(800) 255-8008

in CA (800) 742-1133 in Canada (800) 237-1136

BORLAND

INTERNATIONAL

4585 SC0TTS VALLEY DRIVE SC0TTS VALLEY, CA 95066 (408)438-8400 TELEX: 172373

Only $99.95!

Technical Specifications

ST Compiler. One-pass optimizing compiler generating linkable object modules. Included is Borland's highperformance Turbo Linker The object module is compatible with the PCDOS linker. Supports tiny, small, compact medium, large, and huge memory model libraries. Can mix models with near and far pointers. Includes floating point emulator (utilizes 8087/ 80287 if installed).

S' Interacts Editor The system includes a powerful, interactive full-screen text editor. If the compiler detects an error, the editor automatically positions the cursor appropriately m the source code.

S' Development Environment A powerful "Make" is included so that managing Turbo C program development is highly efficient Also includes pulldown menus and windows.

Sf Links with relocatable object modules created using Borland's Turbo Prolog • into a single program.

S' Inline assembly code.

S' Loop optimizations

S f Register variables

ST ANSI C compatible.

3 f Start-up routine source code included.

Bf Both command line and integrated environment versions included.

S' License to the source code for Runtime Library available.

Sieve benchmark

Turbo C

Microsoft*

C

Compile time

2.4

13-51

Compile and link time

4.1

18.13

Execution

time

395

5.93

Object code size

239

249

Execution

size

5748

7136

Price

$99.95

$450.00

Table caption’Benchmark nil on an IBM PS 2 Model 60 using Turt>o C version 1.0 and me lrt>o U*er version 10. Microsoft C version 40 and tne MS overlay Imker version 3.51

Minimum system requirements: 3¥ PC. XT. AT. PS 2 and true ccmoat des PC-D0S (MS-DOS) 20 or ater 384<