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 (draw-line thick x1 y1 x2 y2)
  52   (format #f "drawline ~a ~a ~a ~a ~a"
  53           thick x1 y2 x2 y2))
  54
  55 (define (grob-cause offset grob)
  56   (let*
  57       ((cause (event-cause grob))
  58        (tag (if (and cause (integer? (ly:event-property cause 'input-tag)))
  59                 (ly:event-property cause 'input-tag)
  60                 -1))
  61        (name (assoc-get 'name (ly:grob-property grob 'meta))))
  62
  63     (apply format #f
  64            "cause ~a \"~a\" ~a ~a ~a ~a\n" tag name
  65            (grob-bbox grob offset))))
  66
  67 (define (named-glyph font glyph)
  68   (format #f "glyphshow ~a \"~a\" ~a \"~a\""
  69           (ly:font-glyph-name-to-charcode font glyph)
  70           (ly:font-name font)
  71           (modified-font-metric-font-scaling font)
  72           glyph))
  73
  74 (define (no-origin)
  75   "nocause\n")
  76
  77 (define (placebox x y s)
  78   (if (not (string-null? s))
  79       (format #f "at ~a ~a ~a\n" x y s)
  80       ""))
  81
  82 (define (polygon xy-coords blot do-fill)
  83   (format #f "polygon ~a ~a ~a"
  84           blot
  85           (if do-fill "True" "False")
  86           (string-join (map number->string xy-coords))))
  87
  88 (define (round-filled-box breapth width depth height blot-diameter)
  89   (format #f "draw_round_box ~a ~a ~a ~a ~a"
  90           breapth width depth height blot-diameter))
  91
  92 (define (utf-8-string descr string)
  93   (format #f "utf-8 \"~a\" \"~a\""
  94           (escape-string descr)
  95           ;; don't want unescaped spaces.
  96           (escape-string string)))