Current Surreal-numbers code

;;; -*- 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)))

;;This tests if a given list has a specific element

(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)))))))))

                                        ;This takes a set and a function
                                        ;and a function which can
                                        ;compair two sets
(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)))))
                                        ;This adds up all of the values
                                        ;in a given set (list of numbers)

(define (member>=? xl xr)
  (setcmp-f? >= xl xr))
                                        ;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 creates the union 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)))))))
;;;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 exlample {(0) |(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)))
(define (Surreal+1 surreal-number)
  (make-surreal
   (surreal-dydactic-function (xl surreal-number)
                              (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-number 2))))
;;;Finite enumeration is done by streams
(define surreal-number-set+
  (str-maker surreal+1 zero))
(define surreal-number-set-
  (str-maker surreal-1 zero))
(define surreal+1)
;;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))))))