(define-module (scm output-ascii-script)
  )

(use-modules (guile)
	     (lily))

(define this-module (current-module))

(define font-name-alist  '())

(define-public (as-output-expression expr port)
  (display (eval expr this-module) port)
  )


(debug-enable 'backtrace)

(define (tex-encoded-fontswitch name-mag)
  (let* ((iname-mag (car name-mag))
	 (ename-mag (cdr name-mag)))
    (cons iname-mag
	  (cons ename-mag
		(string-append  "magfont"
			  (string-encode-integer
			   (hashq (car ename-mag) 1000000))
			  "m"
			  (string-encode-integer
			   (inexact->exact (* 1000 (cdr ename-mag)))))))))

(define (fontify name-mag-pair exp)
  (string-append (select-font name-mag-pair)
		 exp))


(define (define-fonts internal-external-name-mag-pairs)
  (set! font-name-alist (map tex-encoded-fontswitch
			     internal-external-name-mag-pairs))
  (apply string-append
	 (map (lambda (x)
		(font-load-command (car x) (cdr x)))
	      (map cdr font-name-alist))))

(define (dot x y radius) "") ;; TODO

(define (beam width slope thick)
  (string-append
   (func "set-line-char" "#")
   (func "rline-to" width (* width slope))
   ))

					; simple flat slurs
(define (bezier-bow l thick)
  (let (
	(c0 (cadddr l))
	(c1 (cadr l))
	(c3 (caddr l)))
    (let* ((x (car c0))
	   (dx (- (car c3) x))
	   (dy (- (cdr c3) (cdr c0)))
	   (rc (/ dy dx))
	   (c1-dx (- (car c1) x))
	   (c1-line-y (+ (cdr c0) (* c1-dx rc)))
	   (dir (if (< c1-line-y (cdr c1)) 1 -1))
	   (y (+ -1 (* dir (max (* dir (cdr c0)) (* dir (cdr c3)))))))
      (string-append
       (func "rmove-to" x y)
       (func "put" (if (< 0 dir) "/" "\\\\"))
       (func "rmove-to" 1 (if (< 0 dir) 1 0))
       (func "set-line-char" "_")
       (func "h-line" (- dx 1))
       (func "rmove-to" (- dx 1) (if (< 0 dir) -1 0))
       (func "put" (if (< 0 dir) "\\\\" "/"))))))


(define (bracket arch_angle arch_width arch_height height arch_thick thick)
  ;; width now fixed?
  (let ((width 1))
    (string-append
     (func "rmove-to" (+ width 1) (- (/ height -2) 1))
     (func "put" "\\\\")
     (func "set-line-char" "|")
     (func "rmove-to" 0 1)
     (func "v-line" (+ height 1))
     (func "rmove-to" 0 (+ height 1))
     (func "put" "/")
     )))

(define (polygon points blotdiameter) "") ;; TODO

(define (char i)
  (func "char" i))

(define (define-origin a b c ) "")

(define (end-output) 
  (func "end-output"))

(define (experimental-on)
  "")

(define (filledbox breapth width depth height)
  (let ((dx (+ width breapth))
	(dy (+ depth height)))
    (string-append 
     (func "rmove-to" (* -1 breapth) (* -1 depth))
     (if (< dx dy)
	 (string-append
	  (func "set-line-char" 
		(if (<= dx 1) "|" "#"))
	  (func "v-line" dy))
	 (string-append
	  (func "set-line-char" 
		(if (<= dy 1) "-" "="))
	  (func "h-line" dx))))))

(define (roundfilledbox breapth width depth height blot)
  (filledbox breapth width depth height))

(define (draw-line thick x1 y1 x2 y2)
  (let ((dx (- x2 x1))
	(dy (- y2 y1)))
    (string-append
     (func ("rmove-to" x1 y1))
     (filledbox 0 dx 0 dy))))
	     
(define (font-load-command name-mag command)
  ;; (display "name-mag: ")
  ;; (write name-mag)
  ;; (display "command: ")
  ;; (write command)
  (func "load-font" (car name-mag) (cdr name-mag)))

(define (header creator generate) 
  (func "header" creator generate))

(define (header-end) 
  (func "header-end"))

;; urg: this is good for half of as2text's execution time
(define (xlily-def key val)
  (string-append "(define " key " " (arg->string val) ")\n"))

(define (lily-def key val)
  (if
   ;; let's not have all bloody definitions
   (or (equal? key "lilypondpaperlinewidth")
       (equal? key "lilypondpaperstaffheight")
       (equal? key "lilypondpaperoutputscale"))
   (string-append "(define " key " " (arg->string val) ")\n")
   ""))

(define (no-origin) "")

(define (placebox x y s) 
  (let ((ey (inexact->exact y)))
    (string-append "(move-to " (number->string (inexact->exact x)) " "
		   (if (= 0.5 (- (abs y) (abs ey)))
		       (number->string y)
		       (number->string ey))
		   ")\n" s)))

(define (select-font name-mag-pair)
  (let* ((c (assoc name-mag-pair font-name-alist)))
    (if (eq? c #f)
	(begin
	  (ly:warn 
	   (string-append 
	    "Programming error: No such font known " 
	    (car name-mag-pair))))
	"")				; issue no command
    (func "select-font" (car name-mag-pair))))

(define (start-system width height)
  (func "start-system" width height))

(define (stop-system)
  (func "stop-system"))

(define (stop-last-system)
  (func "stop-system"))


(define (text s)
  (func "text" s))

(define (tuplet ht gap dx dy thick dir) "")

