Category : Files from Magazines
Archive   : CLM89DEC.ZIP
Filename : OCHS.LST

 
Output of file : OCHS.LST contained in archive : CLM89DEC.ZIP
(DEFINE MAKERAT ; Builds a rational from the individual inputs.
(LAMBDA (NUM DENOM SIGN SIZE EXACT)
(LIST (LIST NUM DENOM) (LIST SIGN SIZE) EXACT)))

(DEFINE MR ; Shortcut to makerat using defaults.
(LAMBDA (NUM DENOM)
(LET ((NEG (AND (OR (NEGATIVE? NUM) (NEGATIVE? DENOM))
(NOT
(AND (NEGATIVE? NUM) (NEGATIVE? DENOM))))))
(MAKERAT (ABS NUM) (ABS DENOM) NEG 100 #T))))

(DEFINE GCDRAT ; Returns the greatest common denominator of a
; rational.
(LAMBDA (ARAT)
(GCD (CAAR ARAT) (CADAR ARAT))))

(DEFINE REDUCERAT ; Reduces a rational to its most succint
; representation.
(LAMBDA (ARAT)
(LET ((X (GCDRAT ARAT)))
(MAKERAT (QUOTIENT (CAAR ARAT) X) (QUOTIENT (CADAR ARAT) X)
(CAADR ARAT) (CADADR ARAT) (CADDR ARAT)))))

(DEFINE *RAT ; Rational multiplication.
(LAMBDA (ARAT BRAT)
(REDUCERAT
(MAKERAT (* (CAAR ARAT) (CAAR BRAT))
(* (CADAR ARAT) (CADAR BRAT))
(IF (EQUAL? (CAADR ARAT) (CAADR BRAT))
NIL
())
(IF (>= (CADADR ARAT) (CADADR BRAT))
(CADADR BRAT)
(CADADR ARAT))
(IF (AND (CADDR ARAT) (CADDR BRAT))
T
())))))

(DEFINE /RAT ; rational division.
(LAMBDA (ARAT BRAT)
(REDUCERAT
(MAKERAT (* (CAAR ARAT) (CADAR BRAT))
(* (CADAR ARAT) (CAAR BRAT))
(IF (EQUAL? (CAADR ARAT) (CAADR BRAT))
NIL
())
(IF (>= (CADADR ARAT) (CADADR BRAT))
(CADADR BRAT)
(CADADR ARAT))
(IF (AND (CADDR ARAT) (CADDR BRAT))
T
())))))

(DEFINE +RAT ; Rational addition.
(LAMBDA (ARAT BRAT)
(LET ((SIGNTEST ()) ; SIGNTEST DENOTES DIFFERENT SIGNS IF TRUE
(NUMA (CAAR ARAT)) (DENOMA (CADAR ARAT))
(NUMB (CAAR BRAT)) (DENOMB (CADAR BRAT))
(X (LCM (CADAR ARAT) (CADAR BRAT))))
(SET! NUMA (* NUMA (QUOTIENT X DENOMA)))
(SET! NUMB (* NUMB (QUOTIENT X DENOMB)))
(IF (CAADR ARAT)
(SET! NUMA (MINUS NUMA)))
(IF (CAADR BRAT)
(SET! NUMB (MINUS NUMB)))
(SET! NUMA (+ NUMA NUMB))
(IF (NEGATIVE? NUMA)
(LIST (SET! NUMA (MINUS NUMA)) (SET! SIGNTEST #T))
(SET! SIGNTEST ()))
(REDUCERAT
(MAKERAT NUMA X SIGNTEST
(IF (>= (CADADR ARAT) (CADADR BRAT))
(CADADR BRAT)
(CADADR ARAT))
(IF (AND (CADDR ARAT) (CADDR BRAT))
#T
()))))))

(DEFINE -RAT ; Rational subtraction.
(LAMBDA (ARAT BRAT)
(LET ((SIGNTEST ()) ; SIGNTEST DENOTES DIFFERENT SIGNS IF TRUE
(NUMA (CAAR ARAT)) (DENOMA (CADAR ARAT))
(NUMB (CAAR BRAT)) (DENOMB (CADAR BRAT))
(X (LCM (CADAR ARAT) (CADAR BRAT))))
(SET! NUMA (* NUMA (QUOTIENT X DENOMA)))
(SET! NUMB (* NUMB (QUOTIENT X DENOMB)))
(IF (CAADR ARAT)
(SET! NUMA (MINUS NUMA)))
(IF (CAADR BRAT)
(SET! NUMB (MINUS NUMB)))
(SET! NUMA (- NUMA NUMB))
(IF (NEGATIVE? NUMA)
(LIST (SET! NUMA (MINUS NUMA)) (SET! SIGNTEST #T))
(SET! SIGNTEST ()))
(REDUCERAT
(MAKERAT NUMA X SIGNTEST
(IF (>= (CADADR ARAT) (CADADR BRAT))
(CADADR BRAT)
(CADADR ARAT))
(IF (AND (CADDR ARAT) (CADDR BRAT))
#T
()))))))

(DEFINE RAT-TO-REAL
; translates a rational to a real representation.
(LAMBDA (ARAT)
(/ (CAAR ARAT) (CADAR ARAT))))

(DEFINE RETRAT ; Real to rational primitive.
(LAMBDA (AREAL MULT)
(LET* ((X 10) (TEMP (ABS AREAL)) (RT (ROUND TEMP))
(FT (FLOOR TEMP))
(CT (CEILING TEMP)))
(COND
; Note that the rational is marked as not exact due to conversion
((EQV? TEMP RT) (MAKERAT RT MULT () 100 ()))
((EQV? TEMP FT) (MAKERAT FT MULT () 100 ()))
((EQV? TEMP CT) (MAKERAT CT MULT () 100 ()))
(ELSE (RETRAT (* AREAL X) (* MULT X)))))))

(DEFINE REAL-TO-RAT ; Translates a real to rational format.
(LAMBDA (AREAL)
(LET ((X 1))
(TRIM-RAT (RETRAT AREAL X) 16))))

(DEFINE SUPERLENGTH
; Superlenght counts all of the characters in a list of integers
(LAMBDA (ACONT)
(LET ((CARLENGTH (LENGTH (EXPLODE (CAR ACONT)))))
(COND
((<= (LENGTH ACONT) 0) 0)
(ELSE (+ CARLENGTH (SUPERLENGTH (CDR ACONT))))))))

(DEFINE TRIM-RAT ; Trims a rational to the supplied decimals.
; NDEC is the number of supplied decimals.
(LAMBDA (ARAT NDEC)
; Convert rational to continued
(LET* ((CONTREP (RAT-TO-CONT ARAT))
; LCOUNT is the total length in digits less the suffix
(LCOUNT (- (SUPERLENGTH CONTREP)
(LENGTH (EXPLODE (CAR CONTREP)))))
; The last part of the continued fraction.
(LASTPART ()))
(DEFINE TESTCARRY
; Tests to see if a carry operation is necessary
(LAMBDA (LASTPART)
; Select the first number in lastpart
(LET ((T1 (CAR LASTPART)))
(COND
((= T1 1) #T) ; Always carry on one.
((= T1 2) ; Conditional carry on two.
(COND
((> (LENGTH LASTPART) 1) ())
(ELSE #T)))
(ELSE ()))))) ; Never carry if greater than two.
(DEFINE PTRIM ; Primitive triming operation.
(LAMBDA (CONTREP LASTPART LCOUNT)
(LET* ((NCOUNT (LENGTH (EXPLODE (CAR CONTREP))))
; size of last denom
(REST (- LCOUNT NCOUNT))) ; remmainig digits
(COND
((OR (>= REST NDEC) (> NCOUNT NDEC))
; needs further trimming
(SET! LASTPART (CONS (CAR CONTREP) LASTPART))
(PTRIM (CDR CONTREP) LASTPART REST))
(ELSE
(IF (TESTCARRY LASTPART)
(SET-CAR! CONTREP (1+ (CAR CONTREP))))
CONTREP))))) ; done
(COND
((> LCOUNT NDEC) ; Truncation is important
(CONT-TO-RAT (REVERSE (PTRIM (REVERSE CONTREP)
LASTPART LCOUNT))))
(ELSE ARAT)))))

(DEFINE INT-CONV
; The conversion primitive for rational to continued fraction.
(LAMBDA (NUM DENOM RESULT)
(LET* ((AN1 (QUOTIENT DENOM NUM))
(XN1NUM (- DENOM (* NUM AN1)))
(XN1DENOM NUM))
(COND
((<= XN1NUM 0) (CONS AN1 RESULT))
(ELSE (CONS AN1 (INT-CONV XN1NUM XN1DENOM RESULT)))))))

(DEFINE RAT-TO-CONT ; Rational to continued fraction
(LAMBDA (ARAT) ; As shown in Knuth vol2 pg 341
(LET* ((NUM (CAAR ARAT))
(DENOM (CADAR ARAT))
(A0 (QUOTIENT NUM DENOM))
(RESULT ()))
(IF
(> A0 0)
(SET! NUM (- NUM (* A0 DENOM))))
(IF (> NUM 0)
(CONS A0 (INT-CONV NUM DENOM RESULT))
(CONS A0 RESULT)))))

(DEFINE CONT-TO-RAT ; Continued fraction to rational.
(LAMBDA (ACONT) ; Sent a continued fraction.
(LET* ((NUM 1)
(RCONT (REVERSE ACONT))
; Reverse the continued fraction to RCONT.
(DENOM (CAR RCONT))) ; Set the beginning denominator.
(DEFINE PCONTRAT
; Primitive conversion of continued fraction to rational
(LAMBDA (RCONT NUM DENOM)
; Sent the reversed list of continued multipliers
(LET ((LRCONT (LENGTH RCONT)))
(IF (<= LRCONT 1)
(MAKERAT (+ (* DENOM (CAR RCONT)) NUM)
DENOM () 100 #T)
(PCONTRAT (CDR RCONT)
DENOM ; New numerator
(+ (* (CAR RCONT) DENOM) NUM))))))
; New denominator
(IF (> (LENGTH RCONT) 1)
(PCONTRAT (CDR RCONT) NUM DENOM)
(MR DENOM NUM)))))

(DEFINE CONT-TO-REAL ; Converts from continued fraction to real
(LAMBDA (ACONT)
(RAT-TO-REAL (CONT-TO-RAT ACONT))))

(DEFINE REAL-TO-CONT ; Converts from real to continued fraction.
(LAMBDA (AREAL)
(RAT-TO-CONT (REAL-TO-RAT AREAL))))

(DEFINE Euclid ; Euclids algorithm for GCD determination.
(LAMBDA (A B) ; Two integers A and B whose GCD is required.
(LET ((R 0)) ; Define a local variable for remainder
(COND
((= B 0) A) ; If B = 0 the algorithm has ended return A.
(ELSE ; Continue recursively
(SET! R (REMAINDER A B)) ; Form A mod B
(SET! A B) ; Set a to the previous B
(SET! B R) ; Set B to the previious remainder
(Euclid A B)))))) ; Call Euclid recursively.


  3 Responses to “Category : Files from Magazines
Archive   : CLM89DEC.ZIP
Filename : OCHS.LST

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/