#lang racket
(provide insert generate-figure)
;;----------------------------------------
(require (planet wcy/anaphora))
(require racket/port)
(require "mpost-utils.rkt")
(define *mpost-stream* (make-parameter 1))
(define (my-find-executable-path program)
  (or 
   (find-executable-path program)
   (find-executable-path (string-append program ".exe"))))

(define /dev/null-out
  (make-output-port
   'null
   always-evt
   (lambda (s start end non-block? breakable?) (- end start))
   void
   (lambda (special non-block? breakable?) #t)
   (lambda (s start end) (wrap-evt
                          always-evt
                          (lambda (x)
                            (- end start))))
   (lambda (special) always-evt)))
(define (call-process program . args)
  (let-values (((proc in out err) 
                (apply subprocess #f #f #f 
                       (my-find-executable-path program)
                       args)))
    (close-output-port out)
    (copy-port in (current-output-port))
    (close-input-port in)
    (close-input-port err)
    (subprocess-wait proc)))

(define mpost-pre 
  (make-parameter 
   "
input TEX;
prologues := 1;
%if scantokens(mpversion) < 1.200:
%   filenametemplate
%else:
%   outputtemplate :=
%fi
% \"%j.eps\";

beginfig(1)
"))
(define mpost-post 
  (make-parameter
   "currentpicture := currentpicture shifted 
                      -llcorner currentpicture shifted (1cm,2cm);
    endfig;
     end;"))
(define (mpost-stream-port)
  (if (output-port? (*mpost-stream*))
      (*mpost-stream*)
      (current-output-port)))
(define (insert . args)
  (for ((arg (in-list args)))
       (write-string arg (mpost-stream-port))))
(define (generate-eps job-name fun-name)  
  (define (create-mp-file-name job-name)
    (path-add-suffix job-name ".mp"))
  (define (generate-mp-file out)
    (parameterize ((*mpost-stream* out))
      (insert (mpost-pre))
      (fun-name)
      (insert (mpost-post))))
  (define (rename-to-eps-file job-name)
    (when (file-exists? (path-add-suffix job-name ".1"))
      (rename-file-or-directory
       (path-add-suffix job-name ".1")
       (path-add-suffix job-name ".eps")
       #t)))
  (define (convert-to-png job-name)
    (let ((eps-file-name (path-add-suffix job-name ".eps"))
          (png-file-name (path-add-suffix job-name ".png")))
      (aif (my-find-executable-path "gs")
           (call-process it
                         "-q"
                         "-r300"
                         "-dEPSCrop"
                         "-dTextAlphaBits=4"
                         "-sDEVICE=png16m"
                         (string-append "-sOutputFile=" (path->string png-file-name))
                         "-dBATCH" "-dNOPAUSE"
                         eps-file-name)
           (printf "warning: gs is not found in path ~a\n" (getenv "PATH")))))
  (define (mpost-check-log log-name)
    (let ((log (file->string log-name)))
      (if (not (regexp-match #px"1 output file written:" log)) log #f)))
  (define (mpost-failed? job-name)
    (let ((log-name (path-add-suffix job-name ".log")))
      (or (not (file-exists? log-name))
          (mpost-check-log log-name))))
  (let* ((mp-file-name (create-mp-file-name job-name)))
    (call-with-output-file*  mp-file-name generate-mp-file #:exists 'replace)
    (parameterize ((current-output-port /dev/null-out))
      (call-process "mpost" "-jobname" job-name mp-file-name))
    (aif (mpost-failed? job-name)
         (begin (display (file->string mp-file-name))
                (newline)
                (display it)
                (with-handlers ((exn:fail:filesystem? (lambda _ _)))
                  (delete-file (path-add-suffix  job-name ".png")))
                #f)
         (begin
           (rename-to-eps-file job-name)
           (convert-to-png job-name)
           job-name))))
(define (check-program-installed prog f)
  (aif (my-find-executable-path prog)
       it
      (raise (f (format "~a is not found. path is ~a" prog (getenv "PATH"))))))
(require "mpost-new-name.rkt")
(define (generate-figure name func)
  (check-program-installed "mpost" (lambda (x) x))
  (reset-new-var)
  (let* ((name (if (path? name) name (string->path name)))
         (path (or (path-only name) (current-directory)))
         (file-name (file-name-from-path name)))
    (parameterize ((current-directory path))
      (generate-eps file-name func))))