Welcome to the CHICKEN Scheme pasting service

(use cairo data-structures srfi-13)

(define s (cairo-image-surface-create-from-png "gazette-chicken.png"))

(define c (cairo-create s))

(define text (string-append "\"" (string-upcase (second (argv))) "\""))

(define (text-width ctxt text)
  (let ((ex (make-cairo-text-extents-type)))
    (cairo-text-extents ctxt text ex)
    (cairo-text-extents-width ex)))

(define (text->rows ctxt text max-width)
  (let* ((w (text-width ctxt text))
         (f (inexact->exact (floor (* (string-length text) (/ max-width w))))))
    (let loop ((s text)
               (r '()))
      (cond ((string-null? s) (reverse r))
            ((< (text-width ctxt s) max-width)
             (loop "" (cons s r)))
            ((string-index s #\space (if (< f (string-length s)) f 0))
             => (lambda (i)
                  (loop (string-drop s (add1 i))
                        (cons (string-take s (add1 i))
                              r))))
            (else (loop "" (cons s r)))))))



(cairo-select-font-face c "Impact" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL)
(cairo-set-font-size c 30)

(cairo-move-to c 20 50)
(cairo-set-source-rgba c 1 0 0 1)
(cairo-show-text c "The chicken says:")

(cairo-set-font-size c 20)

(let ((rs (text->rows c text 220.0)))
  (when (> (length rs) 4)
    (error (sprintf "String too long by ~a chars." (string-length (last rs)))))
  (for-each (lambda (t o)
              (cairo-move-to c 20 (+ 100 (* o 30)))
              (cairo-show-text c t))
            rs '(0 1 2 3)))

(cairo-surface-write-to-png s "foo.png")

(use cairo data-structures srfi-13 srfi-71)

(define s (cairo-image-surface-create-from-png "gazette-chicken.png"))

(define c (cairo-create s))

(define text (string-append "\"" (string-upcase (second (argv))) "\""))

(define (text-width ctxt text font-size)
  (let ((ex (make-cairo-text-extents-type)))
    (cairo-set-font-size ctxt font-size)
    (cairo-text-extents ctxt text ex)
    (values (cairo-text-extents-width ex)
            (cairo-text-extents-height ex))))

(define (text->rows ctxt text max-width font-size)
  (let* ((w (text-width ctxt text font-size))
         (f (inexact->exact (floor (* (string-length text) (/ max-width w))))))
    (let loop ((s text)
               (r '()))
      (cond ((string-null? s) (reverse r))
            ((< (text-width ctxt s font-size) max-width)
             (loop "" (cons s r)))
            ((string-index s #\space (if (< f (string-length s)) f 0))
             => (lambda (i)
                  (loop (string-drop s (add1 i))
                        (cons (string-take s (add1 i))
                              r))))
            (else (loop "" (cons s r)))))))

(define (find-rows-and-size c text boundary-width boundary-height font-size)
  (let ((rs (text->rows c text boundary-width font-size))
        (width height (text-width c text font-size)))
    (cond ((< font-size 6)
           (printf "Error: String is still too long by ~a chars. And would be illegible.~%"
                   (fold (lambda (x s) (+ (string-length x) s))
                         0
                         (drop rs 4)))
           (exit 1))
          ((> (* (+ (* 0.2 height) (length rs)) height) boundary-height )
           (find-rows-and-size c text boundary-width boundary-height (- font-size 2)))
          (else rs))))

(cairo-select-font-face c "Impact" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL)


(cairo-move-to c 20 50)
(cairo-set-source-rgba c 1 0 0 1)
(cairo-set-font-size c 30)
(cairo-show-text c "The chicken says:")

(for-each (lambda (t o)
            (cairo-move-to c 20 (+ 90 (* o 30)))
            (cairo-show-text c t))
          (find-rows-and-size c text 220.0 100 20)
          '(0 1 2 3))

(cairo-surface-write-to-png s "foo.png")

(use cairo data-structures srfi-1 srfi-13)

(define s (cairo-image-surface-create-from-png "gazette-chicken.png"))
(define c (cairo-create s))
(define ex (make-cairo-text-extents-type))
(define text (string-append "\"" (string-upcase (second (argv))) "\""))

(define *spacing* 0.4)

(define (text-width ctxt text font-size)
  (cairo-set-font-size ctxt font-size)
  (cairo-text-extents ctxt text ex)
  (values (cairo-text-extents-width ex)
          (cairo-text-extents-height ex)))

(define (text->rows ctxt text max-width font-size)
  (let-values (((w) (text-width ctxt text font-size)))
              (let ((f (inexact->exact (floor (* (string-length text) (/ max-width w))))))
                (let loop ((s text)
                           (r '()))
                  (cond ((string-null? s) (reverse r))
                        ((< (text-width ctxt s font-size) max-width)
                         (loop "" (cons s r)))
                        ((string-index-right (string-take s (min f (string-length s))) #\space)
                         => (lambda (i)
                              (loop (string-drop s (add1 i))
                                    (cons (string-take s (add1 i))
                                          r))))
                        (else (loop "" (cons s r))))))))

(define (find-rows-and-size c text boundary-width boundary-height font-size)
  (let ((rs (text->rows c text boundary-width font-size)))
    (let-values (((width height) (text-width c text font-size)))
                (cond ((< font-size 10)
                       (printf "Error: String is still too long by ~a chars. And would be illegible.~%"
                               (fold (lambda (x s) (+ (string-length x) s))
                                     0
                                     (drop rs 4)))
                       (exit 1))
                      ((> (+
                           (* *spacing* height (length rs))
                           (* (length rs) height))
                          boundary-height)
                       (printf "Retrying with fs ~a (current height ~a, spacing ~a)~%" (- font-size 2)
                               height
                               (* *spacing* height))
                       (find-rows-and-size c text boundary-width boundary-height (- font-size 2)))
                      (else (values rs width height))))))

(cairo-select-font-face c "Impact" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL)


(cairo-move-to c 20 50)
(cairo-set-source-rgba c 1 0 0 1)
(cairo-set-font-size c 30)
(cairo-show-text c "The chicken says:")

(let-values (((rs width height) (find-rows-and-size c text 220.0 100 20)))
            (for-each (lambda (t o)
                        (cairo-move-to c 20 (+ 90 (* o (+ height (* height *spacing*)))))
                        (cairo-show-text c t))
                      rs
                      (iota (length rs))))

(cairo-move-to c 20 200)
(cairo-set-font-size c 12)
(cairo-show-text c "brought to you by #chicken on freenode")

(cairo-surface-write-to-png s "foo.png")