# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1488574876 0
# Node ID b6765c75e28e182ff8a06dd533b1779f651a24bf
# Parent  d5445be606ffe94027a7a5555930cf8d8a1cf082
Start Surreal Numbers book

diff -r d5445be606ff -r b6765c75e28e package.lisp
--- a/package.lisp	Fri Mar 03 20:04:23 2017 +0000
+++ b/package.lisp	Fri Mar 03 21:01:16 2017 +0000
@@ -258,7 +258,7 @@
   (:export
     ))
 
-(defpackage :sand.pq
+(defpackage :sand.surreal-numbers
   (:use
     :cl
     :losh
diff -r d5445be606ff -r b6765c75e28e sand.asd
--- a/sand.asd	Fri Mar 03 20:04:23 2017 +0000
+++ b/sand.asd	Fri Mar 03 21:01:16 2017 +0000
@@ -12,7 +12,6 @@
                #+sbcl :sb-sprof
                :cffi
                :cl-algebraic-data-type
-               :cl-arrows
                :cl-charms
                :cl-fad
                :cl-ppcre
@@ -22,7 +21,6 @@
                :easing
                :flexi-streams
                :function-cache
-               :html-entities
                :iterate
                :losh
                :parenscript
@@ -50,7 +48,6 @@
     :components ((:file "utils")
                  (:file "primes")
                  (:file "graphs")
-                 (:file "pq")
                  (:file "graphviz")
                  (:file "hanoi")
                  (:file "urn")
@@ -81,6 +78,7 @@
                  (:file "istruct")
                  (:file "names")
                  (:file "easing")
+                 (:file "surreal-numbers")
                  (:module "turing-omnibus"
                   :serial t
                   :components ((:file "wallpaper")
diff -r d5445be606ff -r b6765c75e28e src/pq.lisp
--- a/src/pq.lisp	Fri Mar 03 20:04:23 2017 +0000
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,48 +0,0 @@
-(in-package :sand.pq)
-
-;;;; Priority Queue -----------------------------------------------------------
-;;; Jankass priority queue implementation.
-(defstruct pq
-  (contents nil)
-  (predicate #'<)
-  (test #'eql))
-
-
-(defun pqn-priority (node)
-  (first node))
-
-(defun pqn-element (node)
-  (second node))
-
-
-(defun pq-resort (pq)
-  (zapf (pq-contents pq)
-        (sort % (pq-predicate pq) :key #'pqn-priority))
-  pq)
-
-(defun pq-lookup (pq element)
-  (find element (pq-contents pq)
-        :key #'pqn-element
-        :test (pq-test pq)))
-
-(defun pq-insert (pq element priority)
-  (zapf (pq-contents pq)
-        (merge 'list `((,priority ,element)) % (pq-predicate pq)
-               :key #'pqn-priority))
-  pq)
-
-(defun pq-ensure (pq element priority)
-  (let ((existing (pq-lookup pq element)))
-    (if existing
-      (progn (setf (car existing) priority)
-             (pq-resort pq)
-             t)
-      (progn (pq-insert pq element priority)
-             nil)))
-  pq)
-
-(defun pq-dequeue (pq)
-  (if (pq-contents pq)
-    (values (pqn-element (pop (pq-contents pq))) t)
-    (values nil nil)))
-
diff -r d5445be606ff -r b6765c75e28e src/surreal-numbers.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/surreal-numbers.lisp	Fri Mar 03 21:01:16 2017 +0000
@@ -0,0 +1,45 @@
+(in-package :sand.surreal-numbers)
+
+
+(defstruct (surreal (:constructor surreal (left right)))
+  (left nil :type list)
+  (right nil :type list))
+
+
+(defun surreal<= (x y)
+  ;; "One number is less than or equal to another if and only if
+  ;; no member of the first number's left set is greater than or equal to the second number, and
+  ;; no member of the second number's right set is less than or equal to the first number"
+  (and (notany (lambda (n) (surreal>= n y)) (surreal-left x))
+       (notany (lambda (n) (surreal<= n x)) (surreal-right y))))
+
+(defun surreal>= (x y)
+  (surreal<= y x))
+
+(defun surreal< (x y)
+  (and (surreal<= x y)
+       (not (surreal<= y x))))
+
+(defun surreal> (x y)
+  (surreal< y x))
+
+(defun surreal= (x y)
+  (and (surreal<= x y)
+       (surreal<= y x)))
+
+(defun surreal!= (x y)
+  (not (surreal= x y)))
+
+
+(defun check-surreal (surreal)
+  ;; "No member of the left set is greater than or equal to a member of the
+  ;; right set"
+  (dolist (x (surreal-left surreal) t)
+    (dolist (y (surreal-right surreal))
+      (assert (not (surreal>= x y)))))
+  t)
+
+
+(defparameter *0* (surreal nil nil))
+(defparameter *1* (surreal (list *0*) nil))
+(defparameter *-1* (surreal nil (list *0*)))