mathematica.ss
(module mathematica mzscheme
  
  (require "ml.ss"
           "translation.ss"
           (lib "mred.ss" "mred")
           (lib "class.ss")
           (lib "file.ss")
           (lib "etc.ss")
           (lib "contract.ss"))
  
  (define-struct MathLink (ml ref))
  
  (define Eval/c
    (opt->* ((flat-rec-contract Mexp
                                number? boolean? symbol? string? void?
                                (cons/c Mexp (listof Mexp))))
            (MathLink?) any))
  
  (provide/contract (MathKernel
                     (->* () (listof bytes?) (MathLink?)))
                    (MathEval Eval/c)
                    (MathExit
                     (opt-> () (MathLink?) void?))
                    (current-mathlink
                     (parameter/c (or/c false/c MathLink?)))
                    (Mexp->image Eval/c))
  (provide MathLink?
           frontend-mode
           $Display)
  
  (define current-mathlink
    (make-parameter #f))
  
  (define frontend-mode
    (make-parameter #t))
  
  (define $Display
    (make-parameter #t))
  
  (define flush-input
    (let ([buf (make-bytes 16)])
      (lambda ()
        (do ()
          ((zero? (read-bytes-avail!* buf)))))))
  
  (define (MathPutSymbol sym lp)
    (let* ((str (symbol->string sym))
           (lst (string->list str)))
      (if (and (not (null? lst))
               (or (char-alphabetic? (car lst))
                   (char=? (car lst) #\$))
               (andmap (lambda (c)
                         (or (char-alphabetic? c)
                             (char-numeric? c)))
                       (cdr lst)))
          (MathPutNext 35 lp)
          (MathPutFunction 'Symbol 1 lp))
      (MathPutString str lp)))
  
  (define (MathGetNumber lp)
    (string->number (bytes->string/latin-1 (MathGetByteString lp))))
  
  (define (MathPut exp lp)
    (cond ((boolean? exp)
           (MathPutCharSymbol (if exp 'True 'False) lp))
          ((number? exp)
           (MathPutNumber exp lp))
          ((symbol? exp)
           (MathPutSymbol exp lp))
          ((string? exp)
           (MathPutString exp lp))
          ((void? exp)
           (MathPutCharSymbol 'Null lp))
          (else
           (let ((mexp (Scheme->Mathematica exp)))
             (MathPutNext 70 lp)
             (MathPutArgCount (sub1 (length mexp)) lp)
             (andmap (lambda (arg) (MathPut arg lp)) mexp)))))
  
  (define (MathGet1 lp)
    (MathWait lp)
    (parameterize-break
     #f
     (case (MathNextPacket lp)
       ((0)
        (unless (MathClearError lp)
          (error "MathLink fatal error"))
        (MathNewPacket lp)
        (MathGet1 lp))
       ((1)
        (display (MathGetString lp))
        (flush-input)
        (MathPutFunction 'EnterExpressionPacket 1 lp)
        (MathPut (read) lp)
        (MathNewPacket lp)
        (MathGet1 lp))
       ((2)
        (display (MathGetString lp))
        (MathNewPacket lp)
        (MathGet1 lp))
       ((3)
        (MathGetExp lp))
       ((4)
        (MathGetString lp))
       ((5)
        (MathNewPacket lp)
        (MathNextPacket lp)
        (warning (MathGetString lp))
        (MathNewPacket lp)
        (MathGet1 lp))
       ((21)
        (display (MathGetString lp))
        (flush-input)
        (MathPutFunction 'TextPacket 1 lp)
        (MathPutString (read-line (current-input-port) 'any) lp)
        (MathNewPacket lp)
        (MathGet1 lp))
       (else
        (MathNewPacket lp)
        (MathGet1 lp)))))
  
  (define (MathGet2 lp k)
    (MathWait lp)
    (parameterize-break
     #f
     (case (MathNextPacket lp)
       ((0)
        (unless (MathClearError lp)
          (error "MathLink fatal error")))
       ((1)
        (display (MathGetString lp))
        (flush-input)
        (MathPutFunction 'EnterExpressionPacket 1 lp)
        (MathPut (read) lp)
        (MathNewPacket lp)
        (MathGet2 lp k))
       ((2)
        (display (MathGetString lp))
        (MathNewPacket lp)
        (MathGet2 lp k))
       ((16)
        (let ((r (MathGetExp lp)))
          (MathGet2 lp
                    (lambda (dummy) (k r)))))
       ((5)
        (MathNewPacket lp)
        (MathNextPacket lp)
        (warning (MathGetString lp))
        (MathNewPacket lp)
        (MathGet2 lp k))
       ((6)
        (let ((InterruptMenu (MathGetNumber lp)))
          (display (MathGetString lp))
          (MathNewPacket lp)
          (when (zero? InterruptMenu)
            (MathNextPacket lp)
            (display (MathGetString lp))))
        (MathPut (read-line (current-input-port) 'any) lp)
        (MathNewPacket lp)
        (MathGet2 lp k))
       ((8)
        (MathNewPacket lp)
        (k (void)))
       ((17)
        (display "MathKernel suspended\n")
        (MathNewPacket lp)
        (k (void)))
       ((18)
        (display "MathKernel resumed\n")
        (MathNewPacket lp)
        (MathGet2 lp k))
       ((19)
        (printf "entering dialog: ~a\n"
                (bytes->string/latin-1 (MathGetByteString lp)))
        (MathNewPacket lp)
        (MathGet2 lp k))
       ((20)
        (printf "leaving dialog: ~a\n"
                (bytes->string/latin-1 (MathGetByteString lp)))
        (MathNewPacket lp)
        (MathGet2 lp k))
       ((21)
        (display (MathGetString lp))
        (flush-input)
        (MathPutFunction 'TextPacket 1 lp)
        (MathPutString (read-line (current-input-port) 'any) lp)
        (MathNewPacket lp)
        (MathGet2 lp k))
       (else
        (MathNewPacket lp)
        (MathGet2 lp k)))))
  
  (define (MathGetExp lp)
    (case (MathGetNext lp)
      ((35)
       (let ((sym (MathGetSymbol lp)))
         (case sym
           ((True) #t)
           ((False) #f)
           ((Null) (void))
           ((Indeterminate) +nan.0)
           (else sym))))
      ((34)
       (MathGetString lp))
      ((43)
       (MathGetNumber lp))
      ((42)
       (let ((t (MathGetNumber lp)))
         (when (or (= t +inf.0)
                   (= t -inf.0))
           (warning "MathLink: Mathematica returns a real number that doesn't fit in a C double."))
         t))
      ((70)
       (Mathematica->Scheme
        (let* ((n (MathGetArgCount lp))
               (head (list (MathGetExp lp))))
          (do ((i n (sub1 i))
               (p head (cdr p)))
            ((zero? i) head)
            (set-cdr! p (list (MathGetExp lp)))))))))
  
  (define MathKernel
    (case-lambda
      (()
       (if (eq? (system-type 'os) 'unix)
           (MathKernel #"-linkname" #"math -mathlink")
           ;(MathKernel #"-linkmode" #"launch")
           (MathKernel #"-linkname" #"MathKernel -mathlink")))
      (arg
       (let* ((raw-ml (apply init_and_openlink arg))
              (raw-lp (car raw-ml))
              (lp (make-MathLink raw-lp (cdr raw-ml))))
         (current-mathlink lp)
         (MathNextPacket raw-lp)
         (MathNewPacket raw-lp)
         lp))))
  
  (define MathEval
    (opt-lambda (exp (ml (or (current-mathlink) (MathKernel))))
      (let ((lp (MathLink-ml ml)))
        (cond ((frontend-mode)
               (parameterize-break
                #f
                (MathPutFunction 'EnterExpressionPacket 1 lp)
                (MathPut exp lp)
                (MathEndPacket lp))
               (psrender (MathGet2 lp values) ml))
              (else
               (parameterize-break
                #f
                (MathPutFunction 'EvaluatePacket 1 lp)
                (MathPut exp lp)
                (MathEndPacket lp))
               (MathGet1 lp))))))
  
  (define (MathWait lp)
    (with-handlers ((exn:break?
                     (lambda (x)
                       (MathPutMessage (if (frontend-mode)
                                           2 3)
                                       lp))))
      (do ()
        ((MathReady lp))
        (sleep)))
    (unless (zero? (MathError lp))
      (error (string-append "MathLink Error: "
                            (bytes->string/latin-1 (MathErrorMessage lp))))))
  
  (define MathExit
    (case-lambda
      (()
       (cond ((current-mathlink)
              => MathExit)
             (else
              (error 'MathExit "No current MathLink"))))
      ((lp)
       (if (eq? lp (current-mathlink))
           (current-mathlink #f))
       (let ((ml (MathLink-ml lp)))
         (MathPutMessage 1 ml)
         (MathClose ml (MathLink-ref lp))))))
  
  (define Mexp->image
    (opt-lambda (exp (ml (or (current-mathlink) (MathKernel))))
      (let ((lp (MathLink-ml ml)))
        (MathPutFunction 'EvaluatePacket 1 lp)
        (MathPut `(ExportString ,exp "PNG") lp)
        (MathEndPacket lp)
        (let* ((f (make-temporary-file))
               (p (open-output-file f 'replace)))
          (MathNextPacket lp)
          (write-bytes (MathGetByteString lp) p)
          (close-output-port p)
          (begin0 (make-object image-snip% f 'png)
                  (delete-file f))))))
  
  (define (psrender exp lp)
    (if (and ($Display)
             (pair? exp))
        (cond ((memq (car exp)
                     '(Graphics Graphics3D SurfaceGraphics ContourGraphics DensityGraphics GraphicsArray))
               (display (Mexp->image exp lp))
               (newline))
              (else
               (psrender (car exp) lp)
               (psrender (cdr exp) lp))))
    exp))