surreal-numbers


 ;;; -*- mode: scheme surreal-numbers -*- 
 ;;;; Surreal Numbers Datatype 
  
 ;;; This code is written by Joshua Herman and placed in the Public 
 ;;; Domain.  All warranties are disclaimed. 
  
 ;;; For more information about surreal numbers see 
 ;;; http://en.wikipedia.org/wiki/Surreal_numbers 
 ;;; Note: some of the comments are in unicode 
 ;;; Requires SRFI-9 
  
 ;;;Some Helper functions 
  
                                         ;(quote 0) is 0used for nullset 
  
 (define (nullset? x) 
   (equal? x '(0))) 
  
 ;;For readers that accept unicode 
 ;; (define (nullset? x) 
 ;;  (equal? x '∅)) 
  
 (define (set? lat) 
  ((letrec 
      ((S (cond 
           ((null? lat) #t) 
           ((member? (car lat) (cdr lat)) #f) 
           (else (set? (cdr lat))))) 
       (member? (cond 
                 ((null? lat) #f) 
                 (else (or (equal? (car lat) a) 
                           (member? a (cdr lat))))))) 
     (S lat)))) 
                                         ;set? tests if a given list has all 
                                         ;unique elements. 
  
 (define (setcmp-f? test? lat1 lat2) 
   (cond 
    ((or (null? lat1) 
         (null? lat2)) #t) 
   ((or (not (null? (car lat1))) 
       (not (null? (car lat1)))) 
         (test? (car lat1) 
                (car lat2))) 
     (else (set-cmp-f? test? (cdr lat1) (cdr lat2))))) 
                                         ;setcmp-f? takes a set and a function 
                                         ;and a function which can 
                                         ;compair two sets 
  
  
  
 (define (member>=? xl xr) 
   (setcmp-f? >= xl xr)) 
                                         ;member>=? adds up all of the values 
                                         ;in a given set (list of numbers) 
                                         ;This compairs if each member of XL is 
                                         ;greater than or equal to XR 
 (define (union set1 set2) 
   (cond 
    ((null? set1) set2) 
    ((member? (car set1) 
              set2) 
     (union (cdr set1) 
            set2) 
     (else (cons (car set1) 
                 (union (cdr set1) 
                        set2)))))) 
                                         ;This performs the union of two sets 
 (define (intersect set1 set2) 
   (cond 
    ((null? set1) 
      '()) 
    ((member? (car set1) set2) 
     (cons (car set1) 
           (intersect (cdr set1) 
                      set2))) 
    (else (intersect (cdr set1) 
                     set2)))) 
                                         ;This performs the intersection 
                                         ;of two sets 
                                          
 (define first$ car) 
  
 (define (build s1 s2) 
   (cons s1 
         (cons s2 '()))) 
  
 (define second$ (lambda (str) ((second str)))) 
  
 (define str-maker 
   (lambda (next n) 
     (build n (lambda () 
                (str-maker next (next n)))))) 
  
 (define frontier 
   (lambda (str n) 
     (cond 
      ((zero? n) '()) 
      (else (cons (first$ str) 
                  (frontier (second$ str) 
                            (- n 1))))))) 
                                         ;Little Schemer exercise stream code 
 ;;;Surreal Number Code Starts Here  
  
                                         ;Surreal numbers are defined as follows. 
                                         ;Given a Surreal Number X = (xl, xr) 
                                         ;where XL and XR are sets. 
                                         ;∀ xl ∈ L ∀ xr ∈ R : ¬(xl ≤ xr). 
                                         ;For example {(0) |(0)} = { | } 
                                         
 (define-record-type :surreal-number 
  (make-surreal l r) 
   surreal-number? 
   (l left-side) 
   (r right-side)) 
                                         ;This defines the surreal number datatype 
                                         ;as a record 
  
 (define (well-formed? surreal-number) 
   (and 
    (set? (l surreal-number)) 
    (set? (x surreal-number)) 
    (not (member=>? (l surreal-number) 
                    (r surreal-number))))) 
                                         ;Check for a well formed surreal number 
                                        
 (define (create-surreal-number l r) 
   (if (well-formed? l r) 
       (make-surreal l r) 
       (display "Error in XL/XR Check Input"))) 
                                         ;This uses the well-formed as a 
                                         ;sanity check and creates a surreal 
  
 (define zero (create-surreal-number '(0) '(0)))  
                                         ;Example (Zero) 
  
 (define (pretty-print-surreal surreal-number) 
  (display "(") (display (l surreal-number)) 
  (display ",") (display (r surreal-number)) (display ")")) 
 (define (display x) 
   (if (surreal? x) 
       (pretty-print-surreal x) 
       (display x))) 
  
                                         ;Uses Knuth's method for displaying 
                                         ;surreals 
 (define (surreal-dydactic-function a b) 
   (/ a (expt 2 b))) 
                                         ;The progression of the next surreal  
                                         ;follows the pattern of this dydactic 
                                         ;fraction 
 (define (Surreal+/-1 surreal-number sign) 
   (make-surreal 
    (surreal-dydactic-function (sign (xl surreal-number))  
                               (sign (xr surreal-number))))) 
  
 (define (+/-one? side) 
   (and (nullset? (car side)) (nullset? (cadr side)))) 
  
 (define (value surreal-number) 
   (+ (addvec (xl surreal-number)) 
      (addvec (xr surreal-number)))) 
 (define (add-surreal surreal-number1 surreal-number2) 
   (make-surreal 
    (union (xl surreal-number1) 
           (xl surreal-number2)) 
    (union (xr surreal-number1) 
           (xr surreal-number2)))) 
 (define (subtract-surreal surreal-number1 surreal-number2) 
   (make-surreal 
    (intersect (xl surreal-number1) 
               (xl surreal-number2)) 
    (intersect (xr surreal-number1) 
               (xr surreal-number2)))) 
 ;;;Finite enumeration is done by streams 
  
  
 (define next-day-surreal-number 
   (str-maker next-surreal zero)) 
 ;;Stream Definitions 
  
 ;;Example 
 ;;(define int (str-maker add1 0)) 
 ;; (define (add1 n) 
 ;;   (+ 1 n)) 
 ;; (define odd 
 ;;   (str-maker (lambda (n) 
 ;;                (+ 2 n)) -1)) 
 ;; (define Q 
 ;;   (lambda (str n) 
 ;;     (cond 
 ;;      ((zero? (remainder (first$ str)  n)) 
 ;;      (Q (second$ str) n)) 
 ;;      (else (build 
 ;;             (first$ str) 
 ;;             (lambda () 
 ;;               (Q (second$ str) n))))))) 
 ;; (define P 
 ;;   (lambda (str) 
 ;;     (build (first$ str) 
 ;;            (lambda () 
 ;;              P (Q str (first$ str)))))) 

category-code