#lang scheme/base
(require scribble/manual
scribble/core
scribble/decode
scribble/bnf
scribble/scheme
scribble/html-properties
scribble/latex-properties
scribble/scheme
scriblib/figure
"bib.ss"
(for-label scheme/base
scribble/manual
scribble/decode
scribble/core
scribble/eval
scribble/srcdoc
scribble/extract
(only-in slideshow pict? circle)
scribblings/quick/mreval
scribble/lp
scribble/lp-include))
(provide (all-from-out scribble/manual
scribble/bnf
scribble/decode
"bib.ss")
(for-label (all-from-out scheme/base
scribble/manual
scribble/decode
scribble/core
scribble/eval
scribble/srcdoc
scribble/extract
slideshow
scribble/lp
scribble/lp-include)))
(provide extras
no-indent
show-link
code-block
code-block/file
code-elem
scr:code-block
scr:code-elem
~cite citet
snested
lit
fake-section
quoted
next-line
htdp-circle
latex
slatex
attribution
imgfigure
tighten
(all-from-out scriblib/figure)
minipage
lp-minipage
html-author)
(define (extras)
(make-style #f
(list (make-css-addition "extras.css")
(make-tex-addition "extras.tex"))))
(define (no-indent . content)
(make-paragraph (make-style "NoIndent" null)
(decode-content content)))
(define (show-link url)
(link url (elem #:style 'url url)))
(define (read-all-syntaxes str read)
(with-handlers ([void (lambda (e)
(fprintf (current-error-port)
"READ ERROR: ~a\nwhile reading:\n~a\n"
(exn-message e) str)
'())])
(parameterize ([current-input-port (open-input-string str)])
(port-count-lines! (current-input-port))
(let loop ()
(let ([stx (read)])
(if (eof-object? stx) '() (cons stx (loop))))))))
(define (get-identifiers x)
(let loop ([x x] [acc null])
(cond [(identifier? x) (if (syntax-original? x) (cons x acc) acc)]
[(syntax? x)
(let* ([v (syntax-e x)]
[acc
(cond
[(string? v)
(if (syntax-property x 'scribble)
acc
(cons x acc))]
[(number? v) (cons x acc)]
[(boolean? v) (cons x acc)]
[else acc])])
(loop (syntax-e x) acc))]
[(pair? x) (loop (car x) (loop (cdr x) acc))]
[(null? x) acc]
[else acc])))
(define (decorate-id id str)
(to-element (make-just-context (datum->syntax #f (string->symbol str))
(datum->syntax #'here (syntax-e id)))))
(define (decorate-identifier id str)
(cond
[(equal? str "'") str]
[(identifier? id)
(if (char=? #\@ (string-ref str 0))
(make-element #f (list (tt "@") (decorate-id id (substring str 1))))
(decorate-id id str))]
[(string? (syntax-e id))
(schemevalfont str)]
[else
(to-element id)]))
(define (read-syntax*)
(parameterize ([read-accept-reader #t]) (read-syntax)))
(define (expr-decorate strs #:reader [reader read-syntax*])
(let* ([str (apply string-append strs)]
[ids (sort (get-identifiers (read-all-syntaxes str reader))
< #:key syntax-position)]
[len (string-length str)]
[lang-line (regexp-match #rx"^#lang [^\r\n]*" str)])
(append
(if lang-line
(cons (hash-lang)
(apply
append
(map
(lambda (str)
(list " "
(schememodname #,(string->symbol str))))
(cdr (regexp-match* #rx"[-#a-z/0-9]+" (car lang-line))))))
null)
(let loop ([i (if lang-line (string-length (car lang-line)) 0)]
[ids (if lang-line (if (null? ids) null (cdr ids)) ids)])
(if (null? ids)
(if (= i len) '() (list (substring str i)))
(let* ([id (car ids)]
[pos (sub1 (syntax-position id))]
[span (syntax-span id)])
(cond [(pos . < . i)
(loop i (cdr ids))
(error 'expr-decorate "nested identifiers found in: ~e at: ~e" str (syntax->datum id))]
[(pos . > . i)
(cons (substring str i pos)
(loop pos ids))]
[else
(cons (decorate-identifier
id (substring str pos (+ pos span)))
(loop (+ pos span) (cdr ids)))])))))))
(define (split-lines l)
(let loop ([l l][so-far null])
(cond
[(null? l) (if (null? so-far)
null
(cons (reverse so-far) null))]
[(equal? (car l) "\n")
(cons (reverse so-far) (loop (cdr l) null))]
[(and (string? (car l))
(regexp-match #rx"(.*)\n(.*)" (car l)))
=> (lambda (m)
(loop (list* (cadr m)
"\n"
(caddr m)
(cdr l))
so-far))]
[(and (string? (car l))
(regexp-match #rx"(.*)(#lang [a-z/]+)(.*)" (car l)))
=> (lambda (m)
(loop (list* (cadr m)
(tt (caddr m))
(cadddr m)
(cdr l))
so-far))]
[(and (string? (car l))
(regexp-match #rx"(.*?)( +)(.*)" (car l)))
=> (lambda (m)
(loop (list* (cadr m)
(let ([len (string-length (caddr m))])
(if (= len 1)
(make-element 'tt (list " ")) (hspace len)))
(cadddr m)
(cdr l))
so-far))]
[(equal? (car l) "")
(loop (cdr l) so-far)]
[else (loop (cdr l) (cons (car l) so-far))])))
(define (maybe-tt s)
(if (string? s)
(let ([m (regexp-match #rx"^(.*)@(.*)$" s)])
(if m
(make-element #f (list (maybe-tt (cadr m))
(tt "@")
(maybe-tt (caddr m))))
(schemeparenfont s)))
s))
(define (code-block #:reader [reader read-syntax*] . strs)
(make-table
(make-style "CodeBlock" null)
(map
(lambda (l)
(list (make-paragraph plain (cons (hspace 1) (map maybe-tt l)))))
(split-lines (expr-decorate #:reader reader strs)))))
(define (code-elem #:reader [reader read-syntax*] . strs)
(make-element
#f
(map maybe-tt
(car
(split-lines
(expr-decorate #:reader reader
(map (lambda (str) (regexp-replace #rx"\n" str " "))
strs)))))))
(define (code-block/file filename)
(code-block
(apply string-append
(call-with-input-file filename
(lambda (port)
(let loop ()
(let ([line (read-line port 'any)])
(if (eof-object? line)
'()
(list* line "\n" (loop))))))))))
(require (only-in scribble/reader [read-syntax scr:read-syntax]))
(define (scr:code-block . strs)
(keyword-apply code-block '(#:reader) (list scr:read-syntax) strs))
(define (scr:code-elem . strs)
(keyword-apply code-elem '(#:reader) (list scr:read-syntax) strs))
(define (snested . str)
(make-nested-flow (make-style "Nested" null)
(list
(make-nested-flow (make-style "NestedInside" null)
(decode-flow str)))))
(define (lit str)
(make-element 'tt (list str)))
(define (fake-section . str)
(apply bold "1" (hspace 2) str))
(define (quoted . strs)
(make-nested-flow
(make-style 'inset null)
(decode-flow strs)))
(define (next-line) (make-element "NextLine" null))
(define-syntax-rule (htdp-circle)
(begin
(require (for-label teachpack/htdp/image))
(scheme circle)))
(define latex (make-element "latexName" '("LaTeX")))
(define slatex (make-element "slatexName" '("SLaTeX")))
(define (attribution . content)
(make-paragraph (make-style "Attribution" null)
(decode-content content)))
(define (tighten) (make-element "Tighten" null))
(define (imgfigure img
#:scale [scale 0.5]
#:suffixes [suffixes null]
#:figure [figure figure]
tag . str)
(figure tag
(decode-content str)
(make-paragraph
plain
(image #:scale scale #:suffixes suffixes img))))
(define (lp-minipage . content)
(make-nested-flow
(make-style "LPminipage" null)
(decode-flow content)))
(define (minipage . content)
(make-nested-flow
(make-style "Minipage" null)
(decode-flow content)))
(define (html-author . names)
(make-nested-flow (make-style "HTMLAuthors" null) (list (apply author names))))