;;; Based on "On Numbers and Games", by J.H. Conway

(defstruct (no (:constructor make-no-low-level)
               (:print-function no-print))
  left right)

(defun make-no (left right)
  (let ((left (if (listp left) left (list left)))
        (right (if (listp right) right (list right))))
    (make-no-low-level :left (remove-duplicates left :test #'no-=)
                       :right (remove-duplicates right :test #'no-=))))

(defun no-print (no stream depth)
  (declare (ignore depth))
  (format stream "{~{~a~^, ~} | ~{~a~^, ~}}" (no-left no) (no-right no)))

(defun no-numberp (x)
  (loop for xl in (no-left x) do
       (loop for xr in (no-right x) do
            (when (no->= xl xr)
              (return-from no-numberp nil))))
  t)

(defun no->= (x y &rest more-numbers)
  (and (notany #'(lambda (xr) (no-<= xr y)) (no-right x))
       (notany #'(lambda (yl) (no-<= x yl)) (no-left y))
       (or (null more-numbers)
           (apply #'no->= y more-numbers))))

(defun no-<= (x y &rest more-numbers)
  (apply #'no->= (nreverse (append (list x y) more-numbers))))

(defun no-= (x &rest more-numbers)
  (let ((numbers (cons x more-numbers)))
    (and (apply #'no->= numbers) (apply #'no->= (nreverse numbers)))))

(defun no-> (x y &rest more-numbers)
  (and (no->= x y) (not (no->= y x))
       (or (null more-numbers)
           (apply #'no-> y more-numbers))))

(defun no-< (x y &rest more-numbers)
  (apply #'no-> (nreverse (append (list x y) more-numbers))))

(defun no-+ (x y &rest more-numbers)
  (and x y
       (let ((x+y (make-no (append (mapcar #'(lambda (xl) (no-+ xl y))
                                           (no-left x))
                                   (mapcar #'(lambda (yl) (no-+ x yl))
                                           (no-left y)))
                           (append (mapcar #'(lambda (xr) (no-+ xr y))
                                           (no-right x))
                                   (mapcar #'(lambda (yr) (no-+ x yr))
                                           (no-right y))))))
         (if more-numbers
             (apply #'no-+ x+y more-numbers)
             x+y))))

(defun no-- (x &rest more-numbers)
  (and x
       (if more-numbers
           (no-+ x (mapcar #'no-- more-numbers))
           (make-no (mapcar #'no-- (no-right x))
                    (mapcar #'no-- (no-left x))))))

(defun no-* (x y &rest more-numbers)
  (and x y
       (flet ((term (fx fy)
                (mapcan #'(lambda (x2)
                            (mapcar #'(lambda (y2)
                                        (no-+ (no-* x2 y)
                                              (no-* x y2)
                                              (no-- (no-* x2 y2))))
                                    (funcall fy y)))
                        (funcall fx x))))
         (let ((left1 (term #'no-left #'no-left))
               (left2 (term #'no-right #'no-right))
               (right1 (term #'no-left #'no-right))
               (right2 (term #'no-right #'no-left)))
           (let ((x*y (make-no (append left1 left2)
                               (append right1 right2))))
             (if more-numbers
                 (apply #'no-* x*y more-numbers)
                 x*y))))))

;; (define-symbol-macro no-0 (make-no nil nil))
;; (assert (no-numberp no-0))
;; (assert (no->= no-0 no-0))
;; (assert (no-= (no-- no-0) (no-+ no-0 no-0) no-0))

;; (define-symbol-macro no-1 (make-no no-0 nil))
;; (define-symbol-macro no--1 (make-no nil no-0))
;; (assert (not (no->= no-0 no-1)))
;; (assert (no->= no-1 no-0))
;; (assert (no-> no-1 no-0))
;; (assert (no-< no--1 no-0))
;; (assert (no-< no--1 no-1))
;; (assert (not (no->= no--1 no-1)))
;; (assert (no->= no-1 no--1))
;; (assert (no-> no-1 no--1))
;; (assert (no->= no-1 no-1))