hairiest.lisp

(defun print-xapping (xapping stream depth)
  (declare (ignore depth))
  (format stream
          ;; Are you ready for this one?
          "~:[{~;[~]~:{~S~:[->~S~;~*~]~:^ ~}~:[~; ~]~
           ~{~S->~^ ~}~:[~; ~]~[~*~;->~S~;->~*~]~:[}~;]~]"
          ;; Is that clear?
          (xectorp xapping)
          (do ((vp (xectorp xapping))
               (sp (finite-part-is-xetp xapping))
               (d (xapping-domain xapping) (cdr d))
               (r (xapping-range xapping) (cdr r))
               (z '() (cons (list (if vp (car r) (car d))
                                  (or vp sp)
                                  (car r))
                            z)))
              ((null d) (reverse z)))
          (and (xapping-domain xapping)
               (or (xapping-exceptions xapping)
                   (xapping-infinite xapping)))
          (xapping-exceptions xapping)
          (and (xapping-exceptions xapping)
               (xapping-infinite xapping))
          (ecase (xapping-infinite xapping)
            ((nil) 0)
            (:constant 1)
            (:universal 2))
          (xapping-default xapping)
          (xectorp xapping)))

(defun print-xapping (xapping stream depth)
  (declare (ignore depth))
  (~format (~ stream)
    (~wrap (if (xectorp xapping)
               (values "[" "]")
               (values "{" "}"))
      (mapc (let ((vp (xectorp xapping))
                  (sp (finite-part-is-xetp xapping)))
              (lambda (domain range)
                (~S (if vp range domain))
                (when (or vp sp) "->" (~S range))
                ((~^ :when :last-sublist))
                " "))
            (xapping-domain xapping)
            (xapping-range xapping))
      (when (and (xapping-domain xapping)
                 (or (xapping-exceptions xapping)
                     (xapping-infinite xapping)))
        " ")
      (dolist (~ (xapping-exceptions xapping))
        (~S ~) "->" ~^ " ")
      (when (and (xapping-exceptions xapping)
                 (xapping-infinite xapping))
        " ")
      (ecase (xapping-infinite xapping)
        ((nil))
        (:constant "->" (xapping-default xapping))
        (:universal "->")))))