Saturday, July 22, 2006

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