scm/output-socket.scm

   1 ;;;; output-socket.scm
   2 ;;;;
   3 ;;;; implement network-based output (socket) in Scheme
   4
   5 (define-module (scm output-socket)
   6   #:re-export (quote))
   7
   8 (use-modules (guile)
   9              (srfi srfi-1)
  10              (srfi srfi-13)
  11              (lily))
  12
  13
  14 (define format ergonomic-simple-format)
  15
  16 (define (event-cause grob)
  17   (let*
  18     ((cause (ly:grob-property grob 'cause)))
  19
  20     (if (ly:stream-event? cause)
  21         cause
  22         #f)))
  23
  24 (define (grob-bbox grob offset)
  25   (let*
  26     ((x-ext (ly:grob-extent grob grob X))
  27      (y-ext (ly:grob-extent grob grob Y))
  28      (x (car offset))
  29      (y (cdr offset)))
  30
  31     (if (interval-empty? x-ext)
  32         (set! x-ext '(0 . 0)))
  33
  34     (if (interval-empty? y-ext)
  35         (set! y-ext '(0 . 0)))
  36
  37     (list (+ x (car x-ext))
  38           (+ y (car y-ext))
  39           (+ x (cdr x-ext))
  40           (+ y (cdr y-ext)))))
  41
  42 (define (escape-string str)
  43   (string-regexp-substitute
  44     " " "\\040"
  45     (string-regexp-substitute "\"" "\\\"" str)))
  46
  47 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  48 ;;; stencil commands
  49 ;;;
  50
  51 (define (bezier-sandwich lst thick)
  52   (format "bezier_sandwich ~a [~a]"
  53           thick
  54           (string-append
  55             (string-join (map
  56                            (lambda (x)
  57                              (format "(~a,~a)" (car x) (cdr x)))
  58                            lst)
  59                          ","))))
  60
  61 (define (draw-line thick x1 y1 x2 y2)
  62   (format "drawline ~a ~a ~a ~a ~a"
  63           thick x1 y2 x2 y2))
  64
  65 (define (grob-cause offset grob)
  66   (let*
  67     ((cause (event-cause grob))
  68      (tag (if (and cause (integer? (ly:event-property cause 'input-tag)))
  69               (ly:event-property cause 'input-tag)
  70               -1))
  71      (name (assoc-get 'name (ly:grob-property grob 'meta))))
  72
  73     (apply format
  74            (append (list "cause ~a \"~a\" ~a ~a ~a ~a\n" tag name)
  75                    (grob-bbox grob offset)))))
  76
  77 (define (named-glyph font glyph)
  78   (format "glyphshow ~a \"~a\" ~a \"~a\""
  79           (ly:font-glyph-name-to-charcode font glyph)
  80           (ly:font-name font)
  81           (modified-font-metric-font-scaling font)
  82           glyph))
  83
  84 (define (no-origin)
  85   "nocause\n")
  86
  87 (define (placebox x y s)
  88   (if (not (string-null? s))
  89       (format "at ~a ~a ~a\n" x y s)
  90       ""))
  91
  92 (define (polygon xy-coords blot do-fill)
  93   (format "polygon ~a ~a ~a"
  94           blot
  95           (if do-fill "True" "False")
  96           (string-join (map number->string xy-coords))))
  97
  98 (define (round-filled-box breapth width depth height blot-diameter)
  99   (format "draw_round_box ~a ~a ~a ~a ~a"
 100           breapth width depth height blot-diameter))
 101
 102 (define (utf-8-string descr string)
 103   (format "utf-8 \"~a\" \"~a\""
 104           (escape-string descr)
 105           ;; don't want unescaped spaces.
 106           (escape-string string)))