clearance
parent
cc60dbbb31
commit
9279750b2e
@ -1,5 +1,8 @@
|
||||
#lang info
|
||||
(define collection 'multi)
|
||||
(define deps '(("base" #:version "6.0") "sugar" "csp" "rackunit-lib" "hyphenate" "at-exp-lib" "data-lib" "draw-lib" "gui-lib" "math-lib" "plot-gui-lib" "plot-lib" "profile-lib" "typed-racket-lib"))
|
||||
(define build-deps '("racket-doc" "scribble-lib" "draw-doc" "scribble-doc"))
|
||||
(define deps '("beautiful-racket-lib"
|
||||
"txexpr"
|
||||
("base" #:version "6.0") "sugar" "csp" "rackunit-lib" "hyphenate" "at-exp-lib" "data-lib" "draw-lib" "gui-lib" "math-lib" "plot-gui-lib" "plot-lib" "profile-lib" "typed-racket-lib"))
|
||||
(define build-deps '("debug"
|
||||
"racket-doc" "scribble-lib" "draw-doc" "scribble-doc"))
|
||||
(define update-implies '("sugar"))
|
||||
|
||||
Binary file not shown.
@ -1,13 +0,0 @@
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base) racket/list sugar/debug "quads.rkt" "error.rkt")
|
||||
(provide (except-out (all-from-out racket/base) #%module-begin)
|
||||
(all-from-out racket/list sugar/debug "quads.rkt" "error.rkt")
|
||||
(rename-out [~module-begin #%module-begin])
|
||||
(for-syntax (all-from-out racket/base)))
|
||||
|
||||
(define-syntax-rule (~module-begin . args)
|
||||
(#%module-begin
|
||||
. args))
|
||||
|
||||
(module reader syntax/module-reader
|
||||
#:language 'quad/dev)
|
||||
@ -1,9 +0,0 @@
|
||||
#lang racket/base
|
||||
(provide (all-defined-out))
|
||||
|
||||
(struct exn:quad-overflow exn:fail ())
|
||||
(define (raise-overflow-error)
|
||||
(raise
|
||||
(exn:quad-overflow
|
||||
"overflow error: No breakpoint available. Increase line width"
|
||||
(current-continuation-marks))))
|
||||
@ -1,244 +0,0 @@
|
||||
#lang racket/base
|
||||
(require ffi/unsafe
|
||||
ffi/unsafe/define
|
||||
racket/draw/private/libs)
|
||||
|
||||
(define-syntax-rule (define+provide id val)
|
||||
(begin
|
||||
(define id val)
|
||||
(provide id)))
|
||||
|
||||
(define-runtime-lib freetype-lib
|
||||
[(unix) (ffi-lib "libfontconfig" '("1" ""))]
|
||||
[(macosx) (ffi-lib "libfreetype.6.dylib")]
|
||||
[(windows) (ffi-lib "libfreetype-6.dll")])
|
||||
|
||||
(define-ffi-definer define-freetype freetype-lib #:provide provide)
|
||||
|
||||
;; types
|
||||
(define _void-pointer (_cpointer 'void-pointer))
|
||||
(define _char _byte)
|
||||
(define _char-pointer (_cpointer 'char-pointer))
|
||||
(define _uchar _ubyte)
|
||||
(define _FT_Byte _ubyte)
|
||||
(define _FT_Bytes _bytes)
|
||||
(define _FT_Char _char)
|
||||
(define _FT_Int _int)
|
||||
(define _FT_UInt _uint)
|
||||
(define _FT_Int16 _short)
|
||||
(define _FT_UInt16 _ushort)
|
||||
(define _FT_Int32 _int32)
|
||||
(define _FT_UInt32 _uint32)
|
||||
(define _FT_Short _short)
|
||||
(define _FT_UShort _ushort)
|
||||
(define _FT_Long _long)
|
||||
(define _FT_ULong _ulong)
|
||||
(define _FT_Bool _byte)
|
||||
(define _FT_Offset _size) ;; equivalent to _size_t?
|
||||
(define _FT_PtrDist _ptrdiff) ;; equivalent to _longlong?
|
||||
(define _FT_String _char)
|
||||
(define _FT_String-pointer (_cpointer 'FT_String-pointer)) ;; char*
|
||||
(define _FT_Tag _FT_UInt32)
|
||||
(define _FT_Error _int)
|
||||
(define _FT_Fixed _long)
|
||||
(define _FT_Pointer _void-pointer)
|
||||
(define _FT_Pos _long)
|
||||
(define _FT_FWord _short)
|
||||
(define _FT_UFWord _ushort)
|
||||
(define _FT_F26Dot16 _short)
|
||||
(define _FT_F26Dot6 _long)
|
||||
(define _FT_Glyph_Format _int)
|
||||
(define _FT_Encoding _int)
|
||||
(define _FT_Generic_Finalizer (_cpointer '_FT_Generic_Finalizer (_fun _void-pointer -> _void)))
|
||||
|
||||
(define _FT_LibraryRec (_cpointer 'FT_LibraryRec))
|
||||
(define _FT_Library (_cpointer 'FT_Library))
|
||||
|
||||
(define-cstruct _FT_Bitmap_Size
|
||||
([height _FT_Short]
|
||||
[width _FT_Short]
|
||||
[size _FT_Pos]
|
||||
[x_ppem _FT_Pos]
|
||||
[y_ppem _FT_Pos]))
|
||||
|
||||
(define-cstruct _FT_CharMapRec
|
||||
([face _void-pointer] ; should be FT_Face
|
||||
[encoding _FT_Encoding]
|
||||
[platform_id _FT_UShort]
|
||||
[encoding_id _FT_UShort]))
|
||||
|
||||
(define _FT_Charmap _FT_CharMapRec-pointer)
|
||||
(define _FT_CharMap-pointer (_cpointer 'FT_CharMap-pointer))
|
||||
|
||||
(define-cstruct _FT_Generic
|
||||
([data _void-pointer]
|
||||
[finalizer _FT_Generic_Finalizer]))
|
||||
|
||||
(define-cstruct _FT_BBox
|
||||
([xMin _FT_Pos]
|
||||
[yMin _FT_Pos]
|
||||
[xMax _FT_Pos]
|
||||
[yMax _FT_Pos]))
|
||||
|
||||
(define-cstruct _FT_Glyph_Metrics
|
||||
([width _FT_Pos]
|
||||
[height _FT_Pos]
|
||||
[horiBearingX _FT_Pos]
|
||||
[horiBearingY _FT_Pos]
|
||||
[horiAdvance _FT_Pos]
|
||||
[vertBearingX _FT_Pos]
|
||||
[vertBearingY _FT_Pos]
|
||||
[vertAdvance _FT_Pos]))
|
||||
|
||||
(define-cstruct _FT_Vector
|
||||
([x _FT_Pos]
|
||||
[y _FT_Pos]))
|
||||
|
||||
(provide (struct-out FT_Vector)
|
||||
_FT_Vector _FT_Vector-pointer)
|
||||
|
||||
(define-cstruct _FT_Bitmap
|
||||
([rows _int]
|
||||
[width _int]
|
||||
[pitch _int]
|
||||
[buffer (_cpointer 'buffer)]
|
||||
[num_grays _short]
|
||||
[pixel_mode _ubyte]
|
||||
[palette_mode _char]
|
||||
[palette _void-pointer]))
|
||||
|
||||
(define-cstruct _FT_Outline
|
||||
([n_contours _short]
|
||||
[n_points _short]
|
||||
[points _FT_Vector-pointer]
|
||||
[tags (_cpointer 'tags)]
|
||||
[contours (_cpointer 'contours)]
|
||||
[flags _int]))
|
||||
|
||||
(define-cstruct _FT_GlyphSlotRec
|
||||
([library _FT_Library]
|
||||
[face _void-pointer]
|
||||
[next _void-pointer]
|
||||
[reserved _uint]
|
||||
[generic _FT_Generic]
|
||||
[metrics _FT_Glyph_Metrics]
|
||||
[linearHoriAdvance _FT_Fixed]
|
||||
[linearVertAdvance _FT_Fixed]
|
||||
[advance _FT_Vector]
|
||||
[format _FT_Glyph_Format]
|
||||
[bitmap _FT_Bitmap]
|
||||
[bitmap_left _FT_Int]
|
||||
[bitmap_top _FT_Int]
|
||||
[outline _FT_Outline]
|
||||
[num_subglyphs _FT_UInt]
|
||||
[subglyphs _void-pointer]
|
||||
[control_data _void-pointer]
|
||||
[control_len _long]
|
||||
[lsb_delta _FT_Pos]
|
||||
[rsb_delta _FT_Pos]
|
||||
[other _void-pointer]
|
||||
[internal _void-pointer]))
|
||||
|
||||
(define _FT_GlyphSlot _FT_GlyphSlotRec-pointer)
|
||||
|
||||
(provide (struct-out FT_GlyphSlotRec)
|
||||
_FT_GlyphSlotRec _FT_GlyphSlotRec-pointer)
|
||||
|
||||
(define-cstruct _FT_Size_Metrics
|
||||
([x_ppem _FT_UShort]
|
||||
[y_ppem _FT_UShort]
|
||||
[x_scale _FT_Fixed]
|
||||
[y_scale _FT_Fixed]
|
||||
[ascender _FT_Pos]
|
||||
[descender _FT_Pos]
|
||||
[height _FT_Pos]
|
||||
[max_advance _FT_Pos]))
|
||||
|
||||
(define-cstruct _FT_SizeRec
|
||||
([face _void-pointer]
|
||||
[generic _FT_Generic]
|
||||
[metrics _FT_Size_Metrics]
|
||||
[internal _void-pointer]))
|
||||
|
||||
(define _FT_Size _FT_SizeRec-pointer)
|
||||
|
||||
(define-cstruct _FT_FaceRec
|
||||
([num_faces _FT_Long]
|
||||
[face_index _FT_Long]
|
||||
[face_flag _FT_Long]
|
||||
[style_flags _FT_Long]
|
||||
[num_glyphs _FT_Long]
|
||||
[family_name _string] ; probably _string is a better choice
|
||||
[style_name _string]
|
||||
[num_fixed_sizes _FT_Int]
|
||||
[available_sizes _FT_Bitmap_Size-pointer]
|
||||
[num_charmaps _FT_Int]
|
||||
[charmaps _FT_CharMap-pointer]
|
||||
[generic _FT_Generic]
|
||||
[bbox _FT_BBox]
|
||||
[units_per_EM _FT_UShort]
|
||||
[ascender _FT_Short]
|
||||
[descender _FT_Short]
|
||||
[height _FT_Short]
|
||||
[max_advance_width _FT_Short]
|
||||
[max_advance_height _FT_Short]
|
||||
[underline_position _FT_Short]
|
||||
[underline_thickness _FT_Short]
|
||||
[glyph _FT_GlyphSlot]
|
||||
[size _FT_Size]
|
||||
[charmap _FT_Charmap]
|
||||
[driver _void-pointer]
|
||||
[memory _void-pointer]
|
||||
[stream _void-pointer]
|
||||
[sizes_list_head _void-pointer]
|
||||
[sizes_list_tail _void-pointer]
|
||||
[autohint _FT_Generic]
|
||||
[extensions _void-pointer]
|
||||
[internal _void-pointer]))
|
||||
|
||||
(define _FT_Face _FT_FaceRec-pointer)
|
||||
(provide (struct-out FT_FaceRec)
|
||||
_FT_FaceRec _FT_FaceRec-pointer)
|
||||
|
||||
(define _full-path
|
||||
(make-ctype _path
|
||||
path->complete-path
|
||||
values))
|
||||
|
||||
(define-freetype FT_Init_FreeType (_fun (ftl : (_ptr o _FT_Library))
|
||||
-> (err : _FT_Error)
|
||||
-> (if (zero? err) ftl (error 'FT_Init_FreeType))))
|
||||
|
||||
(define-freetype FT_New_Face (_fun _FT_Library _full-path _FT_Long
|
||||
(ftf : (_ptr o (_or-null _FT_Face)))
|
||||
-> (err : _FT_Error)
|
||||
-> (if (zero? err) ftf (error 'FT_New_Face (format "error ~a" err)))))
|
||||
|
||||
(define-freetype FT_Done_Face (_fun _FT_Face
|
||||
-> (err : _FT_Error)
|
||||
-> (unless (zero? err) (error 'FT_Done_Face (format "error ~a" err)))))
|
||||
|
||||
(define-freetype FT_Done_FreeType (_fun _FT_Library -> (err : _FT_Error) -> (if (zero? err) (void) (error 'FT_Done_FreeType))))
|
||||
|
||||
(define-freetype FT_Get_Kerning (_fun _FT_Face _FT_UInt _FT_UInt _FT_UInt
|
||||
(ftv : (_ptr o _FT_Vector))
|
||||
-> (err : _FT_Error)
|
||||
-> (if (zero? err) ftv (error 'FT_Get_Kerning (format "error ~a" err)))))
|
||||
|
||||
(define-freetype FT_Get_Char_Index (_fun _FT_Face _FT_ULong
|
||||
-> _FT_UInt))
|
||||
|
||||
(define-freetype FT_Load_Glyph (_fun _FT_Face _FT_UInt _FT_Int32
|
||||
-> (err : _FT_Error)))
|
||||
|
||||
(define-freetype FT_Load_Char (_fun _FT_Face _FT_ULong _FT_Int32
|
||||
-> (err : _FT_Error)))
|
||||
|
||||
(define+provide FT_KERNING_UNSCALED 2)
|
||||
(define+provide FT_LOAD_DEFAULT 0)
|
||||
(define+provide FT_LOAD_RENDER (expt 2 2))
|
||||
(define+provide FT_LOAD_LINEAR_DESIGN (expt 2 13))
|
||||
(define+provide FT_LOAD_NO_RECURSE (expt 2 10))
|
||||
|
||||
|
||||
|
||||
@ -1,4 +1,3 @@
|
||||
#lang info
|
||||
|
||||
(define compile-omit-paths '("old-master"))
|
||||
(define test-omit-paths '("old-master"))
|
||||
(define collection "quad")
|
||||
(define version "0.0")
|
||||
|
||||
@ -1,21 +0,0 @@
|
||||
#lang quad/dev
|
||||
(require "quads.rkt" "typeset.rkt" "atomize.rkt" "render.rkt" "render-pdf.rkt" racket/list racket/string)
|
||||
(provide (except-out (all-from-out quad/dev "quads.rkt") #%module-begin)
|
||||
(rename-out [~module-begin #%module-begin]))
|
||||
|
||||
(define-syntax-rule (~module-begin lang-line-config-arg . args)
|
||||
(#%module-begin
|
||||
(define main-quad (apply quad #f (list . args))) ; at-reader splits lines, but we want one contiguous run
|
||||
;; branch on config-arg to allow debug / inspection options on #lang line
|
||||
(define config-pieces (string-split (string-trim lang-line-config-arg)))
|
||||
(and (pair? config-pieces)
|
||||
(let ([config-args (map string->number (cdr config-pieces))])
|
||||
(case (car config-pieces)
|
||||
[("in") (atomize main-quad)]
|
||||
[("out") (time (apply fit (atomize main-quad) config-args))]
|
||||
[("test") (time (debug-render (apply fit (atomize main-quad) config-args)))]
|
||||
[("pdf") (time (render-pdf (apply fit (atomize main-quad) config-args)))]
|
||||
[else (fit (atomize main-quad))])))))
|
||||
|
||||
(module reader syntax/module-reader
|
||||
quad/main)
|
||||
@ -1,45 +0,0 @@
|
||||
#lang quad/dev
|
||||
(require "freetype-ffi.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define (measure! q)
|
||||
(quad-dim-set! q
|
||||
(cond
|
||||
[(quad-printable? q)
|
||||
(* (measure-char (quad-font q) (quad-val q)) (quad-font-size q))]
|
||||
[else 0])))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(define q ($black '#hasheq((size . 12) (font . "sc.otf")) 0 #\n))
|
||||
(check-equal? (measure-char (quad-font q) (quad-val q)) .6))
|
||||
|
||||
(define measure-char
|
||||
(let ([measure-cache (make-hash)]
|
||||
[glyph-idx-cache (make-hash)]
|
||||
[glyph-width-cache (make-hash)]
|
||||
[em-size-cache (make-hash)]
|
||||
[ft-library (FT_Init_FreeType)]
|
||||
[ft-face-cache (make-hash)])
|
||||
(λ (font-pathstring char)
|
||||
(define (do-measure)
|
||||
(define ft-face (hash-ref! ft-face-cache font-pathstring
|
||||
(λ () (unless (file-exists? font-pathstring)
|
||||
(error 'measure-char (format "font path ~v does not exist" font-pathstring)))
|
||||
(FT_New_Face ft-library font-pathstring 0))))
|
||||
(define width
|
||||
(let ([glyph-idx (hash-ref! glyph-idx-cache (cons char font-pathstring)
|
||||
(λ () (FT_Get_Char_Index ft-face (char->integer char))))])
|
||||
(hash-ref! glyph-width-cache (cons glyph-idx font-pathstring)
|
||||
(λ ()
|
||||
(FT_Load_Glyph ft-face glyph-idx FT_LOAD_NO_RECURSE) ; loads into FTFace's 'glyph' slot
|
||||
(define width (FT_Vector-x (FT_GlyphSlotRec-advance (FT_FaceRec-glyph ft-face))))
|
||||
(* width 1.0))))) ; store as inexact
|
||||
(define em-size
|
||||
(hash-ref! em-size-cache font-pathstring (λ () (FT_FaceRec-units_per_EM ft-face))))
|
||||
(/ width em-size))
|
||||
(hash-ref! measure-cache (cons font-pathstring char) do-measure))))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(check-equal? (measure-char "charter.ttf" #\f) .321))
|
||||
@ -1,48 +0,0 @@
|
||||
#lang racket/base
|
||||
(require racket/runtime-path
|
||||
racket/gui/base
|
||||
racket/class
|
||||
quad/render
|
||||
quad/typeset
|
||||
racket/system)
|
||||
|
||||
(provide make-drracket-buttons)
|
||||
(define-namespace-anchor cache-module-ns)
|
||||
(module test racket/base) ; suppress testing by `raco test`
|
||||
|
||||
(define-runtime-path html-png-path "cmd-char.png")
|
||||
|
||||
#| for toolbar callbacks, see
|
||||
|
||||
http://pkg-build.racket-lang.org/doc/tools/drracket_module-language-tools.html#%28elem._drracket~3atoolbar-buttons%29
|
||||
|
||||
|#
|
||||
|
||||
|
||||
(define (make-render-pdf-button [open? #f])
|
||||
(let ([label (format "Render ~aPDF" (if open? "and Open " ""))]
|
||||
[bitmap (make-object bitmap% html-png-path 'png/mask)]
|
||||
[callback (let ([open? open?])
|
||||
(λ (drr-frame)
|
||||
(define fn (send (send drr-frame get-definitions-text) get-filename))
|
||||
(unless fn
|
||||
(error 'render-pdf "Please save your file first"))
|
||||
(define pdfn (path-replace-suffix fn #".pdf"))
|
||||
(define fn-out (parameterize ([current-namespace (make-base-namespace)])
|
||||
(namespace-attach-module (namespace-anchor->namespace cache-module-ns) 'quad/typeset)
|
||||
(dynamic-require `(submod ,fn outy) 'out)))
|
||||
(when fn-out
|
||||
(define-values (fn-dir name dir?) (split-path fn))
|
||||
(parameterize ([current-directory fn-dir])
|
||||
(local-require "render.rkt" racket/class profile sugar/debug quad/logger quad/world)
|
||||
(activate-logger quad-logger)
|
||||
(send (new pdf-renderer%) render-to-file (typeset fn-out) pdfn))
|
||||
(when open?
|
||||
(parameterize ([current-input-port (open-input-string "")])
|
||||
(system (format "open \"~a\"" (path->string pdfn))))))))]
|
||||
[number (+ 99 (if open? 0 1))])
|
||||
|
||||
(list label bitmap callback number)))
|
||||
|
||||
(define (make-drracket-buttons)
|
||||
(list (make-render-pdf-button) (make-render-pdf-button #t)))
|
||||
Binary file not shown.
|
Before Width: | Height: | Size: 163 B |
@ -1,73 +0,0 @@
|
||||
#lang racket/base
|
||||
(require racket/list sugar/define)
|
||||
(require "samples.rkt" "quads.rkt" "utils.rkt")
|
||||
|
||||
(define ti (block '(measure 54 leading 18) "Meg is " (box '(foo 42)) " ally."))
|
||||
(define tib (block '(measure 240 font "Equity Text B" leading 16 size 13.5 x-align justify x-align-last-line left) (block #f (block '(weight bold font "Equity Caps B") "Hello") (block-break) (box '(width 15)))))
|
||||
|
||||
;ti
|
||||
|
||||
;; convert quad into tokenized representation:
|
||||
;; 1) vector of atomic tokens
|
||||
;; 2) list of (attribute + range of tokens it applies to)
|
||||
;; this representation is designed to:
|
||||
;; 1) preserve all information in the original quad
|
||||
;; 2) be compact / not duplicate information unnecessarily
|
||||
;; 3) allow sequential access to the tokens
|
||||
;; 4) allow fast computation of token state (i.e., attrs that apply)
|
||||
(define+provide (make-tokens-and-attrs quad-in)
|
||||
(define-values (all-tokens all-attrs _)
|
||||
(let loop ([current-quad quad-in][attr-acc empty][starting-tidx 0])
|
||||
(cond
|
||||
[(empty? (quad-list current-quad)); no subelements, so treat this quad as single token
|
||||
(let ([current-quad-attrs (quad-attrs current-quad)]
|
||||
[ending-tidx (add1 starting-tidx)])
|
||||
(values (quad (quad-name current-quad) #f empty)
|
||||
(if current-quad-attrs
|
||||
(cons (vector current-quad-attrs starting-tidx ending-tidx) attr-acc)
|
||||
attr-acc)
|
||||
ending-tidx))]
|
||||
[else ; replace quad with its tokens, exploded
|
||||
(define-values (tokens-from-fold subattrs-from-fold ending-tidx-from-fold)
|
||||
(for/fold ([token-acc empty][subattr-acc empty][tidx starting-tidx])
|
||||
([item (in-list (quad-list current-quad))])
|
||||
(cond
|
||||
[(quad? item)
|
||||
(define-values (sub-tokens sub-attrs sub-last-tidx) (loop item attr-acc tidx))
|
||||
(values (cons sub-tokens token-acc) (cons sub-attrs subattr-acc) sub-last-tidx)]
|
||||
[else ; item is a string of length > 0 (quad contract guarantees this)
|
||||
(define-values (exploded-chars last-idx-of-exploded-chars)
|
||||
(for/fold ([chars empty][last-idx #f])([(c i) (in-indexed item)])
|
||||
(values (cons c chars) i))) ; fold manually to get reversed items & length at same time
|
||||
(values (cons exploded-chars token-acc) subattr-acc (+ tidx (add1 last-idx-of-exploded-chars)))])))
|
||||
(values tokens-from-fold
|
||||
(let ([current-quad-attrs (quad-attrs current-quad)])
|
||||
(if current-quad-attrs
|
||||
(cons (vector current-quad-attrs starting-tidx ending-tidx-from-fold) subattrs-from-fold)
|
||||
subattrs-from-fold))
|
||||
ending-tidx-from-fold)])))
|
||||
(values (list->vector (reverse (flatten all-tokens))) (flatten all-attrs)))
|
||||
|
||||
|
||||
(define-values (tokens attrs) (make-tokens-and-attrs (ti5)))
|
||||
(define+provide current-tokens (make-parameter tokens))
|
||||
(define+provide current-token-attrs (make-parameter attrs))
|
||||
|
||||
;(filter (λ(idx) (box? (vector-ref tokens idx))) (range (vector-length tokens)))
|
||||
|
||||
(define (attr-ref-hash a) (vector-ref a 0))
|
||||
(define (attr-ref-start a) (vector-ref a 1))
|
||||
(define (attr-ref-end a) (vector-ref a 2))
|
||||
|
||||
(define (calc-attrs tref)
|
||||
(map attr-ref-hash (filter (λ(attr) (<= (attr-ref-start attr) tref (sub1 (attr-ref-end attr)))) (current-token-attrs))))
|
||||
|
||||
(module+ main
|
||||
(require rackunit)
|
||||
(define ti (block '(measure 54) "Meg is " (box '(foo 42)) " ally."))
|
||||
(define-values (tokens attrs) (make-tokens-and-attrs ti))
|
||||
(current-tokens tokens)
|
||||
(current-token-attrs attrs)
|
||||
;; todo: repair this test
|
||||
#;(check-equal? tokens (vector #\M #\e #\g #\space #\i #\s #\space (box) #\space #\a #\l #\l #\y #\.))
|
||||
(check-equal? attrs '(#(#hash((measure . 54)) 0 14) #(#hash((foo . 42)) 7 8))))
|
||||
@ -1,75 +0,0 @@
|
||||
#lang racket/base
|
||||
(require ffi/unsafe
|
||||
ffi/unsafe/define
|
||||
ffi/unsafe/alloc
|
||||
setup/dirs
|
||||
racket/draw/private/libs
|
||||
racket/draw/private/utils)
|
||||
|
||||
(define-runtime-lib fontconfig-lib
|
||||
[(unix) (ffi-lib "libfontconfig" '("1" ""))]
|
||||
[(macosx)
|
||||
(ffi-lib "libpng16.16.dylib")
|
||||
(ffi-lib "libexpat.1.dylib")
|
||||
(ffi-lib "libfreetype.6.dylib")
|
||||
(ffi-lib "libfontconfig.1.dylib")]
|
||||
[(windows)
|
||||
(ffi-lib "zlib1.dll")
|
||||
(ffi-lib "libintl-8.dll")
|
||||
(ffi-lib "libpng16-16.dll")
|
||||
(ffi-lib "libexpat-1.dll")
|
||||
(ffi-lib "libfreetype-6.dll")
|
||||
(ffi-lib "libfontconfig-1.dll")])
|
||||
|
||||
(define-syntax-rule (_pfun spec ...)
|
||||
(_fun #:in-original-place? #t spec ...))
|
||||
|
||||
(define-ffi-definer define-fc fontconfig-lib
|
||||
#:provide provide)
|
||||
|
||||
|
||||
;; datatype information from
|
||||
;; http://www.freedesktop.org/software/fontconfig/fontconfig-devel/x31.html
|
||||
(define FcConfig (_cpointer 'FcConfig))
|
||||
(define FcPattern (_cpointer 'FcPattern))
|
||||
(define FcPattern-pointer (_cpointer FcPattern))
|
||||
(define FcObjectSet (_cpointer 'FcObjectSet))
|
||||
|
||||
(define FcBool _bool)
|
||||
(define FcChar8 _bytes)
|
||||
|
||||
(define-cstruct _FcFontSet
|
||||
([nfont _int]
|
||||
[sfont _int]
|
||||
[fonts FcPattern-pointer])) ;; ?? spec says "FcPattern **fonts" but I don't know how this translates to ffi
|
||||
|
||||
|
||||
;; function information from
|
||||
;; http://www.freedesktop.org/software/fontconfig/fontconfig-devel/x102.html
|
||||
(define-fc FcGetVersion (_pfun -> _int))
|
||||
(define-fc FcConfigCreate (_pfun -> FcConfig))
|
||||
(define-fc FcInitLoadConfig (_pfun -> FcConfig))
|
||||
(define-fc FcConfigAppFontAddFile (_pfun FcConfig FcChar8 -> FcBool))
|
||||
(define-fc FcConfigHome (_pfun -> FcChar8))
|
||||
(define-fc FcConfigGetSysRoot(_pfun FcConfig -> FcChar8))
|
||||
(define-fc FcFontList(_pfun FcConfig FcPattern FcObjectSet -> _FcFontSet))
|
||||
(define-fc FcPatternCreate (_pfun -> FcPattern))
|
||||
(define-fc FcFontSetCreate (_pfun -> _FcFontSet))
|
||||
(define-fc FcObjectSetCreate (_pfun -> FcObjectSet))
|
||||
(define-fc FcPatternPrint (_pfun FcPattern -> _void))
|
||||
(define-fc FcPatternEqual (_pfun FcPattern FcPattern -> FcBool))
|
||||
|
||||
;; attempting to replicate font-loading workaround shown at
|
||||
;; https://bugzilla.gnome.org/show_bug.cgi?id=347237#c25
|
||||
(define cfg (FcConfigCreate)) ; workaround step 1
|
||||
(define path (string->bytes/utf-8 "/Users/MB/Desktop/reporter.otf"))
|
||||
|
||||
(FcConfigAppFontAddFile cfg path) ; workaround step 2
|
||||
(define fcp (FcPatternCreate))
|
||||
(define fcos (FcObjectSetCreate))
|
||||
|
||||
(define fs (FcFontList cfg fcp fcos))
|
||||
(define pat (FcFontSet-fonts fs))
|
||||
|
||||
;; this crashes DrRacket, prob because I have mangled the _FcFontSet definition
|
||||
;; (FcPatternPrint pat)
|
||||
@ -1,357 +0,0 @@
|
||||
#lang racket/base
|
||||
(require ffi/unsafe
|
||||
ffi/unsafe/define
|
||||
ffi/unsafe/alloc
|
||||
racket/draw/unsafe/glib
|
||||
racket/draw/unsafe/cairo
|
||||
racket/draw/private/utils
|
||||
racket/draw/private/libs)
|
||||
|
||||
(define-runtime-lib pango-lib
|
||||
[(unix) (ffi-lib "libpango-1.0" '("0" ""))]
|
||||
[(macosx) (ffi-lib "libpango-1.0.0.dylib")]
|
||||
[(windows) (ffi-lib "libpango-1.0-0.dll")])
|
||||
|
||||
(define-runtime-lib pangowin32-lib
|
||||
[(unix) #f]
|
||||
[(macosx)]
|
||||
[(windows)
|
||||
(ffi-lib "libpangowin32-1.0-0.dll")])
|
||||
|
||||
(define-runtime-lib pangocairo-lib
|
||||
[(unix) (ffi-lib "libpangocairo-1.0" '("0" ""))]
|
||||
[(macosx)
|
||||
(ffi-lib "libharfbuzz.0.dylib")
|
||||
(ffi-lib "libpangoft2-1.0.0.dylib")
|
||||
(ffi-lib "libpangocairo-1.0.0.dylib")]
|
||||
[(windows)
|
||||
(ffi-lib "libintl-8.dll")
|
||||
(ffi-lib "libpangowin32-1.0-0.dll")
|
||||
(ffi-lib "libexpat-1.dll")
|
||||
(ffi-lib "libfreetype-6.dll")
|
||||
(ffi-lib "libfontconfig-1.dll")
|
||||
(ffi-lib "libharfbuzz-0.dll")
|
||||
(ffi-lib "libpangoft2-1.0-0.dll")
|
||||
(ffi-lib "libpangocairo-1.0-0.dll")])
|
||||
|
||||
(define-ffi-definer define-pango pango-lib
|
||||
#:provide provide)
|
||||
(define-ffi-definer define-pangocairo pangocairo-lib
|
||||
#:provide provide)
|
||||
(define-ffi-definer define-pangowin32 pangowin32-lib
|
||||
#:provide provide)
|
||||
|
||||
;; Pango's Core Text back-end can somehow go wrong if we're going to eventually
|
||||
;; use AppKit but don't load AppKit it before using functions such as
|
||||
;; `pango_cairo_font_map_get_default'. So, force AppKit now for the platform
|
||||
;; where the Core Text back-end is used:
|
||||
(when (equal? "x86_64-macosx/3m"
|
||||
(path->string (system-library-subpath)))
|
||||
(void (ffi-lib (format "/System/Library/Frameworks/AppKit.framework/AppKit"))))
|
||||
|
||||
;; ALLOCATION NOTE: since Pango calls into Cairo, it has the same
|
||||
;; allocation constraints on arguments as Cairo functions; see
|
||||
;; "cairo.rkt".
|
||||
|
||||
(define PangoContext (_cpointer 'PangoContext))
|
||||
(define PangoLayout (_cpointer 'PangoLayout))
|
||||
(define PangoFontDescription (_cpointer 'PangoFontDescription))
|
||||
(define PangoFontFamily (_cpointer 'PangoFontFamily))
|
||||
(define PangoFontFace (_cpointer 'PangoFontFace))
|
||||
(define PangoFont (_cpointer 'PangoFont))
|
||||
(define PangoFontMap (_cpointer 'PangoFontMap))
|
||||
(define PangoFontMetrics (_cpointer 'PangoFontMetrics))
|
||||
(define PangoAttrList (_cpointer 'PangoAttrList))
|
||||
(define PangoAttribute (_cpointer 'PangoAttribute))
|
||||
(define PangoLanguage (_cpointer 'PangoLanguage))
|
||||
(define PangoCoverage (_cpointer 'PangoCoverage))
|
||||
(define PangoLayoutIter (_cpointer 'PangoLayoutIter))
|
||||
(define PangoLayoutLine (_cpointer 'PangoLayoutLine))
|
||||
|
||||
|
||||
(define-cstruct _PangoRectangle ([x _int]
|
||||
[y _int]
|
||||
[width _int]
|
||||
[height _int])
|
||||
#:malloc-mode 'atomic-interior)
|
||||
(provide make-PangoRectangle
|
||||
PangoRectangle-x
|
||||
PangoRectangle-y
|
||||
PangoRectangle-width
|
||||
PangoRectangle-height)
|
||||
|
||||
(define-cstruct _PangoItem
|
||||
([offset _int]
|
||||
[length _int]
|
||||
[num_chars _int]
|
||||
;; Inline PangoAnalysis:
|
||||
[shape_engine _pointer]
|
||||
[lang_engine _pointer]
|
||||
[font (_or-null PangoFont)]
|
||||
[level _uint8]
|
||||
[gravity _uint8]
|
||||
[flags _uint8]
|
||||
[script _uint8]
|
||||
[language _pointer]
|
||||
[extra_attrs _pointer]))
|
||||
|
||||
(provide (struct-out PangoItem)
|
||||
_PangoItem _PangoItem-pointer)
|
||||
|
||||
(define-cstruct _PangoGlyphInfo
|
||||
([glyph _uint32]
|
||||
[width _uint32]
|
||||
[dx _uint32]
|
||||
[dy _uint32]
|
||||
[is_cluster_start _uint]))
|
||||
|
||||
(provide (struct-out PangoGlyphInfo)
|
||||
_PangoGlyphInfo _PangoGlyphInfo-pointer)
|
||||
|
||||
(define-cstruct _PangoGlyphString
|
||||
([num_glyphs _int]
|
||||
[glyphs _pointer]
|
||||
[log_clusters _pointer])
|
||||
#:malloc-mode 'atomic-interior)
|
||||
|
||||
(provide (struct-out PangoGlyphString)
|
||||
_PangoGlyphString)
|
||||
|
||||
(define-cstruct _PangoGlyphItem ([item _PangoItem-pointer]
|
||||
[glyphs _PangoGlyphString-pointer]))
|
||||
(provide (struct-out PangoGlyphItem))
|
||||
|
||||
;; As of Pango 1.28, Pango is not thread-safe at the C level, which
|
||||
;; means that it isn't place-safe in Racket. Also, for some reason,
|
||||
;; when parts of Pango are initialized in a non-main place under
|
||||
;; Windows, then font operations start to fail when that place exits.
|
||||
;; Run all Pango calls in the original place, which synchronizes them
|
||||
;; and avoids Windows problems.
|
||||
(define-syntax-rule (_pfun spec ...)
|
||||
(_fun #:in-original-place? #t spec ...))
|
||||
|
||||
(provide g_object_unref g_free)
|
||||
(define-gobj g_object_unref (_pfun _pointer -> _void)
|
||||
#:wrap (deallocator))
|
||||
(define-glib g_free (_pfun _pointer -> _void)
|
||||
#:wrap (deallocator))
|
||||
|
||||
;; For working around a Win32 Pango bug (see `unref-font-map'):
|
||||
(define _GQueue (_cpointer 'GQueue))
|
||||
(define-cstruct _PangoWin32FontMap ([type-instance _pointer]
|
||||
[ref_count _uint]
|
||||
[qdata _pointer]
|
||||
[font_cache _pointer]
|
||||
[freed_fonts _GQueue]))
|
||||
(define-glib g_queue_foreach (_pfun _GQueue _fpointer #;(_fun _pointer -> _void) _pointer -> _void))
|
||||
(define-glib g_queue_free (_pfun _GQueue -> _void))
|
||||
(define-glib g_queue_new (_pfun -> _GQueue))
|
||||
(define-gobj raw_g_object_unref _fpointer #:c-id g_object_unref)
|
||||
|
||||
(define (unref-font-map v)
|
||||
(when (eq? (system-type) 'windows)
|
||||
;; For version 1.28 of Pango, reported as Bug 649293:
|
||||
;; Under Windows, PangoWin32FontMap holds a queue of freed
|
||||
;; fonts, and the fonts hold a weak link back to the map.
|
||||
;; Unreffing the font map drops the weak links and *then*
|
||||
;; tries to release the freed fonts, which leads to failures
|
||||
;; releasing the fonts. Work around the bug by manually
|
||||
;; flushing the queue of freed fonts before the font map is
|
||||
;; unreffed.
|
||||
(let ([fm (cast v _pointer _PangoWin32FontMap-pointer)])
|
||||
(g_queue_foreach (PangoWin32FontMap-freed_fonts fm) raw_g_object_unref #f)
|
||||
(g_queue_free (PangoWin32FontMap-freed_fonts fm))
|
||||
(set-PangoWin32FontMap-freed_fonts! fm (g_queue_new))))
|
||||
(g_object_unref v))
|
||||
|
||||
(define-pangocairo pango_cairo_font_map_get_default (_pfun -> PangoFontMap)) ;; not an allocator
|
||||
(define-pangocairo pango_cairo_font_map_new (_pfun -> PangoFontMap)
|
||||
#:wrap (allocator unref-font-map))
|
||||
|
||||
(define-pango pango_context_new (_pfun -> PangoContext)
|
||||
#:wrap (allocator g_object_unref))
|
||||
;; pango_font_map_create_context() is in 1.22 and later
|
||||
(provide pango_font_map_create_context)
|
||||
(define (pango_font_map_create_context fm)
|
||||
(let ([c (pango_context_new)])
|
||||
(pango_context_set_font_map c fm)
|
||||
c))
|
||||
(define-pangocairo pango_cairo_update_context (_pfun _cairo_t PangoContext -> _void))
|
||||
|
||||
;; The convenince function pango_cairo_create_context() is in 1.22 and later
|
||||
(provide pango_cairo_create_context)
|
||||
(define (pango_cairo_create_context cr)
|
||||
(let ([ctx (pango_font_map_create_context
|
||||
(pango_cairo_font_map_get_default))])
|
||||
(pango_cairo_update_context cr ctx)
|
||||
ctx))
|
||||
|
||||
(define-pangocairo pango_cairo_create_layout (_pfun _cairo_t -> PangoLayout)
|
||||
#:wrap (allocator g_object_unref))
|
||||
(define-pangocairo pango_cairo_update_layout (_pfun _cairo_t PangoLayout -> _void))
|
||||
(define-pango pango_layout_set_text (_pfun PangoLayout [s : _string] [_int = -1] -> _void))
|
||||
(define-pangocairo pango_cairo_show_layout (_pfun _cairo_t PangoLayout -> _void))
|
||||
(define-pangocairo pango_cairo_show_layout_line (_pfun _cairo_t PangoLayoutLine -> _void))
|
||||
(define-pangocairo pango_cairo_show_glyph_string (_pfun _cairo_t PangoFont _PangoGlyphString-pointer -> _void))
|
||||
(define-pangocairo pango_cairo_layout_line_path (_pfun _cairo_t PangoLayoutLine -> _void))
|
||||
|
||||
(define-pango pango_layout_iter_free (_pfun PangoLayoutIter -> _void)
|
||||
#:wrap (deallocator))
|
||||
(define-pango pango_layout_get_iter (_pfun PangoLayout -> PangoLayoutIter)
|
||||
#:wrap (allocator pango_layout_iter_free))
|
||||
(define-pango pango_layout_iter_get_baseline (_pfun PangoLayoutIter -> _int))
|
||||
(define-pango pango_layout_iter_next_run (_pfun PangoLayoutIter -> _bool))
|
||||
(define-pango pango_layout_iter_get_run (_pfun PangoLayoutIter -> (_or-null _PangoGlyphItem-pointer)))
|
||||
(define-pango pango_layout_iter_get_run_readonly (_pfun PangoLayoutIter -> (_or-null _PangoGlyphItem-pointer))
|
||||
#:fail (lambda () pango_layout_iter_get_run))
|
||||
|
||||
(define-pango pango_layout_get_line (_pfun PangoLayout _int -> PangoLayoutLine))
|
||||
(define-pango pango_layout_get_line_readonly (_pfun PangoLayout _int -> PangoLayoutLine)
|
||||
#:fail (lambda () pango_layout_get_line))
|
||||
|
||||
(define-pango pango_layout_get_context (_pfun PangoLayout -> PangoContext)) ;; not an allocator
|
||||
;(define-pango pango_layout_get_extents (_pfun PangoLayout _pointer _PangoRectangle-pointer -> _void))
|
||||
(define-pango pango_layout_get_baseline (_pfun PangoLayout -> _int)
|
||||
;; The convenince function pango_layout_get_baseline() is in 1.22 and later
|
||||
#:fail (lambda ()
|
||||
(lambda (layout)
|
||||
(let ([iter (pango_layout_get_iter layout)])
|
||||
(begin0
|
||||
(pango_layout_iter_get_baseline iter)
|
||||
(pango_layout_iter_free iter))))))
|
||||
(define-pango pango_layout_get_spacing (_pfun PangoLayout -> _int))
|
||||
|
||||
(define-pango pango_layout_new (_pfun PangoContext -> PangoLayout)
|
||||
#:wrap (allocator g_object_unref))
|
||||
|
||||
(define-pangocairo pango_cairo_context_get_font_options (_pfun PangoContext -> _cairo_font_options_t)) ;; not an allocator
|
||||
(define-pangocairo pango_cairo_context_set_font_options (_pfun PangoContext _cairo_font_options_t -> _void)) ;; makes a copy
|
||||
|
||||
(define-pango pango_layout_set_font_description (_pfun PangoLayout PangoFontDescription -> _void)) ;; makes a copy
|
||||
(define-pango pango_context_get_font_map (_pfun PangoContext -> PangoFontMap)) ;; not an allocator
|
||||
(define-pango pango_context_set_font_map (_pfun PangoContext PangoFontMap -> _void))
|
||||
(define-pango pango_font_family_get_name (_pfun PangoFontFamily -> _string)) ;; not an allocator
|
||||
(define-pango pango_font_family_is_monospace (_pfun PangoFontFamily -> _bool))
|
||||
|
||||
(define-pango pango_language_get_default (_pfun -> PangoLanguage)
|
||||
;; not available before 1.16
|
||||
#:fail (lambda () (lambda () #f)))
|
||||
(define-pango pango_font_map_load_font (_pfun PangoFontMap PangoContext PangoFontDescription -> (_or-null PangoFont)))
|
||||
(define-pango pango_coverage_unref (_pfun PangoCoverage -> _void)
|
||||
#:wrap (deallocator))
|
||||
(define-pango pango_font_get_coverage (_pfun PangoFont PangoLanguage -> PangoCoverage)
|
||||
#:wrap (allocator pango_coverage_unref))
|
||||
(define-pango pango_coverage_get (_pfun PangoCoverage _int -> _int))
|
||||
|
||||
(define-pango pango_font_metrics_unref (_pfun PangoFontMetrics -> _void)
|
||||
#:wrap (deallocator))
|
||||
(define-pango pango_font_get_metrics (_pfun PangoFont (_or-null PangoLanguage) -> PangoFontMetrics)
|
||||
#:wrap (allocator pango_font_metrics_unref))
|
||||
(define-pango pango_font_metrics_get_approximate_char_width (_pfun PangoFontMetrics -> _int))
|
||||
(define-pango pango_font_metrics_get_ascent (_pfun PangoFontMetrics -> _int))
|
||||
(define-pango pango_font_metrics_get_descent (_pfun PangoFontMetrics -> _int))
|
||||
|
||||
(define-pango pango_layout_get_unknown_glyphs_count (_pfun PangoLayout -> _int)
|
||||
;; not available in old versions:
|
||||
#:fail (lambda () (lambda (lo) 0)))
|
||||
|
||||
(define-pango pango_attr_list_unref (_pfun PangoAttrList -> _void)
|
||||
#:wrap (deallocator))
|
||||
(define-pango pango_attr_list_new (_pfun -> PangoAttrList)
|
||||
#:wrap (allocator pango_attr_list_unref))
|
||||
(define-pango pango_attr_list_insert (_pfun PangoAttrList PangoAttribute -> _void)
|
||||
;; takes ownership of the attribute
|
||||
#:wrap (deallocator cadr))
|
||||
|
||||
(define-pango pango_attribute_destroy (_pfun PangoAttribute -> _void)
|
||||
#:wrap (deallocator))
|
||||
(define-pango pango_attr_underline_new (_pfun _int -> PangoAttribute)
|
||||
#:wrap (allocator pango_attribute_destroy))
|
||||
(define-pango pango_attr_fallback_new (_pfun _bool -> PangoAttribute)
|
||||
#:wrap (allocator pango_attribute_destroy))
|
||||
|
||||
(define-pango pango_layout_set_attributes (_pfun PangoLayout PangoAttrList -> _void))
|
||||
|
||||
(define-pango pango_font_map_list_families (_pfun PangoFontMap
|
||||
(fams : (_ptr o _pointer))
|
||||
(len : (_ptr o _int))
|
||||
-> _void
|
||||
-> (begin0
|
||||
(for/list ([i (in-range len)])
|
||||
(ptr-ref fams PangoFontFamily i))
|
||||
(g_free fams))))
|
||||
(define-pango pango_font_family_list_faces (_pfun PangoFontFamily
|
||||
(faces : (_ptr o _pointer))
|
||||
(len : (_ptr o _int))
|
||||
-> _void
|
||||
-> (begin0
|
||||
(for/list ([i (in-range len)])
|
||||
(ptr-ref faces PangoFontFace i))
|
||||
(g_free faces))))
|
||||
(define-pango pango_font_face_get_face_name (_pfun PangoFontFace -> _string))
|
||||
|
||||
(define-pango pango_font_description_free (_pfun PangoFontDescription -> _void)
|
||||
#:wrap (deallocator))
|
||||
(define-pango pango_font_description_new (_pfun -> PangoFontDescription)
|
||||
#:wrap (allocator pango_font_description_free))
|
||||
(define-pango pango_font_description_from_string (_pfun _string -> PangoFontDescription)
|
||||
#:wrap (allocator pango_font_description_free))
|
||||
(define-pango pango_font_description_set_family (_pfun PangoFontDescription _string -> _void))
|
||||
(define-pango pango_font_description_set_style (_pfun PangoFontDescription _int -> _void))
|
||||
(define-pango pango_font_description_set_weight (_pfun PangoFontDescription _int -> _void))
|
||||
(define-pango pango_font_description_set_size (_pfun PangoFontDescription _int -> _void))
|
||||
(define-pango pango_font_description_set_absolute_size (_pfun PangoFontDescription _double* -> _void))
|
||||
(define-pango pango_font_description_get_family (_pfun PangoFontDescription -> _string))
|
||||
|
||||
(define _PangoWin32FontCache (_cpointer 'PangoWin32FontCache))
|
||||
(define _HFONT (_cpointer 'HFONT))
|
||||
(define _LOGFONT-pointer _pointer)
|
||||
(define-pangowin32 pango_win32_font_map_for_display (_pfun -> PangoFontMap)
|
||||
#:make-fail make-not-available)
|
||||
(define-pangowin32 pango_win32_font_logfont (_pfun PangoFont -> _LOGFONT-pointer)
|
||||
#:make-fail make-not-available
|
||||
#:wrap (allocator g_free))
|
||||
(define-pangowin32 pango_win32_font_description_from_logfont (_pfun _LOGFONT-pointer -> PangoFontDescription)
|
||||
#:make-fail make-not-available
|
||||
#:wrap (allocator pango_font_description_free))
|
||||
(define-pangowin32 pango_win32_font_cache_unload (_pfun _PangoWin32FontCache _HFONT -> _void)
|
||||
#:make-fail make-not-available)
|
||||
(define-pangowin32 pango_win32_font_cache_load (_pfun _PangoWin32FontCache _LOGFONT-pointer -> _HFONT)
|
||||
#:make-fail make-not-available)
|
||||
(define-pangowin32 pango_win32_font_cache_new (_pfun -> _PangoWin32FontCache)
|
||||
#:make-fail make-not-available)
|
||||
|
||||
(define-enum
|
||||
0
|
||||
PANGO_STYLE_NORMAL
|
||||
PANGO_STYLE_OBLIQUE
|
||||
PANGO_STYLE_ITALIC)
|
||||
|
||||
(define-enum
|
||||
0
|
||||
PANGO_UNDERLINE_NONE
|
||||
PANGO_UNDERLINE_SINGLE
|
||||
PANGO_UNDERLINE_DOUBLE
|
||||
PANGO_UNDERLINE_LOW
|
||||
PANGO_UNDERLINE_ERROR)
|
||||
|
||||
(define/provide PANGO_WEIGHT_LIGHT 300)
|
||||
(define/provide PANGO_WEIGHT_MEDIUM 500)
|
||||
(define/provide PANGO_WEIGHT_BOLD 700)
|
||||
|
||||
(define/provide PANGO_SCALE 1024)
|
||||
|
||||
|
||||
(define-pango pango_layout_set_width (_pfun PangoLayout _int -> _void))
|
||||
(define-pango pango_layout_get_width (_pfun PangoLayout -> _int))
|
||||
(define-pango pango_layout_get_character_count (_pfun PangoLayout -> _int))
|
||||
(define-pango pango_layout_copy (_pfun PangoLayout -> PangoLayout))
|
||||
(define-pango pango_layout_get_serial (_pfun PangoLayout -> _uint))
|
||||
(define-pango pango_layout_get_text (_pfun PangoLayout -> _string/utf-8))
|
||||
(define-pango pango_layout_get_attributes (_pfun PangoLayout -> PangoAttrList))
|
||||
(define-pango pango_layout_get_font_description (_pfun PangoLayout -> PangoFontDescription))
|
||||
|
||||
(define-pango pango_font_description_get_size (_pfun PangoFontDescription -> _int))
|
||||
|
||||
(define-pango pango_layout_get_extents (_pfun PangoLayout _PangoRectangle-pointer _PangoRectangle-pointer -> _void))
|
||||
(define-pango pango_layout_get_pixel_extents (_pfun PangoLayout _PangoRectangle-pointer _PangoRectangle-pointer -> _void))
|
||||
@ -1,5 +0,0 @@
|
||||
#lang info
|
||||
|
||||
(define scribblings '(("scribblings/quad.scrbl" ())))
|
||||
(define compile-omit-paths '("tests.rkt" "tests-ocm.rkt"))
|
||||
(define test-omit-paths 'all)
|
||||
@ -1,50 +0,0 @@
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base racket/syntax) sugar/coerce racket/contract)
|
||||
(require "world.rkt" racket/match sugar/debug racket/date racket/list)
|
||||
(module+ test (require rackunit))
|
||||
(provide (all-defined-out))
|
||||
|
||||
|
||||
(define-syntax-rule (define-orphan-logger name)
|
||||
(begin
|
||||
(define remember-cl (current-logger))
|
||||
(define dummy-cl (make-logger))
|
||||
(current-logger dummy-cl)
|
||||
(define-logger name)
|
||||
(current-logger remember-cl)))
|
||||
|
||||
(define-logger quad)
|
||||
|
||||
(define-syntax-rule (activate-logger logger)
|
||||
(begin
|
||||
(define logger-receiver (make-log-receiver logger (world:logging-level)))
|
||||
(define log-file (build-path (current-directory) (format "~a.txt" 'logger)))
|
||||
(with-output-to-file log-file #:exists 'truncate void)
|
||||
(void (thread
|
||||
(λ ()
|
||||
(let loop ()
|
||||
(match (sync logger-receiver)
|
||||
[(vector event-level event-message event-value name)
|
||||
(define msg (format "[~a] ~a\n" event-level event-message))
|
||||
; (eprintf msg)
|
||||
(flush-output)
|
||||
(with-output-to-file log-file #:exists 'append (λ () (display msg)))])
|
||||
(loop))))
|
||||
(log-quad-info "started at ~a" (date->string (current-date) #t)))))
|
||||
|
||||
|
||||
(define-syntax-rule (log-quad-debug-report x)
|
||||
(begin
|
||||
(log-quad-debug "~a = ~a" 'x x)
|
||||
x))
|
||||
|
||||
(define-syntax-rule (log-quad-debug* xs)
|
||||
(when (equal? (world:logging-level) 'debug)
|
||||
(map (λ(x) (log-quad-debug x)) xs)))
|
||||
|
||||
(module+ main
|
||||
(activate-logger quad-logger)
|
||||
(log-quad-fatal "Exterminate! Exterminate!")
|
||||
(log-quad-error "~a" (time (apply + (range 1000))))
|
||||
(log-quad-debug "What's the red button for?"))
|
||||
|
||||
@ -1,52 +0,0 @@
|
||||
#lang racket/base
|
||||
(provide (except-out (all-from-out racket/base) #%module-begin)
|
||||
(rename-out [quad-module-begin #%module-begin]))
|
||||
(require (for-syntax racket/base syntax/strip-context))
|
||||
(require quad/quads quad/typeset quad/world quad/render racket/class)
|
||||
|
||||
(define-syntax (quad-module-begin stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr ...)
|
||||
(replace-context #'(expr ...)
|
||||
#'(#%module-begin
|
||||
(module outy racket/base
|
||||
(require quad/quads)
|
||||
(define out (block '(font "Times New Roman" measure 360.0 leading 14.0 column-count 1 column-gutter 10.0 size 11.5 x-align justify x-align-last-line left) expr ...))
|
||||
(provide out))
|
||||
(require 'outy)
|
||||
(provide (all-from-out 'outy))
|
||||
(displayln out)))]))
|
||||
|
||||
(module reader syntax/module-reader
|
||||
quad/main
|
||||
#:read quad-read
|
||||
#:read-syntax quad-read-syntax
|
||||
#:whole-body-readers? #t ;; need this to make at-reader work
|
||||
#:info custom-get-info
|
||||
(require scribble/reader)
|
||||
|
||||
(define (quad-read p)
|
||||
(syntax->datum (quad-read-syntax (object-name p) p)))
|
||||
|
||||
(define quad-command-char #\@)
|
||||
|
||||
(define (quad-read-syntax path-string p)
|
||||
(define quad-at-reader (make-at-reader
|
||||
#:command-char quad-command-char
|
||||
#:syntax? #t
|
||||
#:inside? #t))
|
||||
(define source-stx (quad-at-reader path-string p))
|
||||
source-stx)
|
||||
|
||||
(define (custom-get-info key default [proc (λ _ #f)])
|
||||
(case key
|
||||
[(color-lexer)
|
||||
(define my-make-scribble-inside-lexer
|
||||
(dynamic-require 'syntax-color/scribble-lexer 'make-scribble-inside-lexer (λ () #f)))
|
||||
(cond [my-make-scribble-inside-lexer
|
||||
(my-make-scribble-inside-lexer #:command-char quad-command-char)]
|
||||
[else default])]
|
||||
[(drracket:toolbar-buttons)
|
||||
(define my-make-drracket-buttons (dynamic-require 'quad/buttons 'make-drracket-buttons))
|
||||
(my-make-drracket-buttons)]
|
||||
[else default])))
|
||||
@ -1,68 +0,0 @@
|
||||
#lang racket/base
|
||||
(require math/flonum racket/draw racket/class sugar/debug sugar/list racket/list sugar/cache racket/serialize racket/file)
|
||||
(provide measure-text measure-ascent round-float update-text-cache-file load-text-cache-file)
|
||||
|
||||
(define precision 4.0)
|
||||
(define base (flexpt 10.0 precision))
|
||||
|
||||
(define-syntax-rule (round-float x)
|
||||
(fl/ (flround (fl* base (fl x))) base))
|
||||
|
||||
(define dc (new record-dc%))
|
||||
|
||||
(define max-size 1024) ; use fixnum to trigger faster bitshift division
|
||||
;; changing max-size invalidates font cache (because it's based on max size, duh)
|
||||
|
||||
(define/caching (make-font/caching font weight style)
|
||||
(make-font #:size max-size #:style style #:weight weight #:face font))
|
||||
|
||||
(define (get-cache-file-path)
|
||||
(build-path "font.cache"))
|
||||
|
||||
(define (update-text-cache-file)
|
||||
(when (current-text-cache-changed?)
|
||||
(write-to-file (serialize (current-text-cache)) (get-cache-file-path) #:exists 'replace)
|
||||
(current-text-cache-changed? #f)))
|
||||
|
||||
(define (load-text-cache-file)
|
||||
(define cache-file-path (get-cache-file-path))
|
||||
(current-text-cache (if (file-exists? cache-file-path)
|
||||
(deserialize (file->value cache-file-path))
|
||||
(make-hash))))
|
||||
|
||||
(define current-text-cache (make-parameter (make-hash)))
|
||||
(define current-text-cache-changed? (make-parameter #f))
|
||||
(define current-font-cache (make-parameter (make-hash)))
|
||||
|
||||
(define/caching (measure-max-size text font [weight 'normal] [style 'normal])
|
||||
;((string? string?) (symbol? symbol?) . ->* . number?)
|
||||
(define font-instance (hash-ref! (current-font-cache) (list font weight style) (λ() (make-font #:size max-size #:style style #:weight weight #:face font))))
|
||||
;; 'combine' boolean only makes a difference for two or more chars
|
||||
(hash-ref! (current-text-cache) (list text font weight style) (λ() (current-text-cache-changed? #t)
|
||||
(values->list (send dc get-text-extent text font-instance (>= (string-length text) 1))))))
|
||||
|
||||
(define-syntax-rule (width x) (first x))
|
||||
(define-syntax-rule (height x) (second x))
|
||||
(define-syntax-rule (descent x) (third x))
|
||||
(define-syntax-rule (extra x) (fourth x))
|
||||
|
||||
(define-syntax-rule (measure-text-max-size text font weight style)
|
||||
(width (measure-max-size text font weight style)))
|
||||
|
||||
(define (measure-text text size font [weight 'normal] [style 'normal])
|
||||
; ((string? flonum? string?) (symbol? symbol?) . ->* . flonum?)
|
||||
;; Native function only accepts integers, so get max-size and scale down to size needed.
|
||||
(define raw-measure (measure-text-max-size text font weight style))
|
||||
(round-float (/ (* (exact->inexact raw-measure) (exact->inexact size)) max-size)))
|
||||
|
||||
|
||||
(define-syntax-rule (measure-ascent-max-size text font weight style)
|
||||
(let ([result-list (measure-max-size text font weight style)])
|
||||
(- (height result-list) (descent result-list))))
|
||||
|
||||
|
||||
(define (measure-ascent text size font [weight 'normal] [style 'normal])
|
||||
; ((string? flonum? string?) (symbol? symbol?) . ->* . flonum?)
|
||||
;; Native function only accepts integers, so get max-size and scale down to size needed.
|
||||
(define raw-baseline-distance (measure-ascent-max-size text font weight style))
|
||||
(round-float (/ (* (exact->inexact raw-baseline-distance) (exact->inexact size)) max-size)))
|
||||
@ -1,448 +0,0 @@
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base racket/syntax))
|
||||
(require racket/list sugar/debug rackunit racket/function racket/vector sugar/cache "logger.rkt")
|
||||
(define-logger ocm)
|
||||
;(activate-logger ocm-logger)
|
||||
|
||||
|
||||
#|
|
||||
Totally monotone matrix searching algorithms.
|
||||
|
||||
The offline algorithm in ConcaveMinima is from Agarwal, Klawe, Moran,
|
||||
Shor, and Wilbur, Geometric applications of a matrix searching algorithm,
|
||||
Algorithmica 2, pp. 195-208 (1987).
|
||||
|
||||
The online algorithm in OnlineConcaveMinima is from Galil and Park,
|
||||
A linear time algorithm for concave one-dimensional dynamic programming,
|
||||
manuscript, 1989, which simplifies earlier work on the same problem
|
||||
by Wilbur (J. Algorithms 1988) and Eppstein (J. Algorithms 1990).
|
||||
|
||||
D. Eppstein, March 2002, significantly revised August 2005
|
||||
|
||||
|#
|
||||
|
||||
(provide smawky? make-ocm reduce reduce2 (prefix-out ocm- (combine-out min-value min-index)))
|
||||
|
||||
(define (select-elements xs is)
|
||||
(map (curry list-ref xs) is))
|
||||
|
||||
(define (odd-elements xs)
|
||||
(select-elements xs (range 1 (length xs) 2)))
|
||||
|
||||
(define (vector-odd-elements xs)
|
||||
(for/vector ([i (in-range (vector-length xs))] #:when (odd? i))
|
||||
(vector-ref xs i)))
|
||||
|
||||
(define (even-elements xs)
|
||||
(select-elements xs (range 0 (length xs) 2)))
|
||||
|
||||
;; Wrapper for the matrix procedure
|
||||
;; that automatically maintains a hash cache of previously-calculated values
|
||||
;; because the minima operations tend to hit the same values.
|
||||
;; Assuming here that (matrix i j) is invariant
|
||||
;; and that the matrix function is more expensive than the cache lookup.
|
||||
|
||||
|
||||
|
||||
(define-syntax-rule (vector-append-item xs value)
|
||||
(vector-append xs (vector value)))
|
||||
|
||||
(define-syntax-rule (vector-set vec idx val)
|
||||
(begin
|
||||
(vector-set! vec idx val)
|
||||
vec))
|
||||
|
||||
(define-syntax-rule (vector-cdr vec)
|
||||
(vector-drop vec 1))
|
||||
|
||||
(define-syntax-rule (vector-empty? vec)
|
||||
(= 0 (vector-length vec)))
|
||||
|
||||
|
||||
(define (integers? x) (and (list? x) (andmap integer? x)))
|
||||
|
||||
;; Reduce phase: make number of rows at most equal to number of cols
|
||||
(define (reduce row-indices col-indices matrix-proc entry->value)
|
||||
;(vector? vector? procedure? procedure? . -> . vector?)
|
||||
(log-ocm-debug "starting reduce phase with")
|
||||
(log-ocm-debug "row-indices = ~a" row-indices)
|
||||
(log-ocm-debug "col-indices = ~a" col-indices)
|
||||
(define (process-stack stack row-idx)
|
||||
(log-ocm-debug "row stack = ~a" stack)
|
||||
(let ([last-stack-idx (sub1 (vector-length stack))])
|
||||
(cond
|
||||
[(and (>= (vector-length stack) 1)
|
||||
(log-ocm-debug "comparing row values at column ~a" (vector-ref col-indices last-stack-idx))
|
||||
(log-ocm-debug "end of row stack (~a) value at column ~a = ~a" (vector-ref stack last-stack-idx) (vector-ref col-indices last-stack-idx) (entry->value (matrix-proc (vector-ref stack last-stack-idx) (vector-ref col-indices last-stack-idx))))
|
||||
(log-ocm-debug "challenger row (~a) value at column ~a = ~a" row-idx (vector-ref col-indices last-stack-idx) (entry->value (matrix-proc row-idx (vector-ref col-indices last-stack-idx))))
|
||||
(> (entry->value (matrix-proc (vector-ref stack last-stack-idx) (vector-ref col-indices last-stack-idx)))
|
||||
(entry->value (matrix-proc row-idx (vector-ref col-indices last-stack-idx)))))
|
||||
|
||||
(log-ocm-debug "challenger row (~a) wins with a new minimum ~a, so end of row stack (~a) is removed" row-idx (entry->value (matrix-proc row-idx (vector-ref col-indices last-stack-idx))) (vector-ref stack last-stack-idx))
|
||||
(process-stack (vector-drop-right stack 1) row-idx)]
|
||||
[else
|
||||
(log-ocm-debug (if (< (vector-length stack) 1)
|
||||
(format "row stack too short for challenge, pushing row ~a" row-idx)
|
||||
(format "challenger row (~a) loses to end of row stack (~a), so ~a joins stack" row-idx (vector-ref stack last-stack-idx) row-idx)))
|
||||
stack])))
|
||||
|
||||
(define reduced-row-indexes
|
||||
(for/fold ([stack (vector)]) ([row-idx (in-vector row-indices)])
|
||||
(let ([stack (process-stack stack row-idx)])
|
||||
(if (= (vector-length stack) (vector-length col-indices))
|
||||
stack
|
||||
(vector-append stack (vector row-idx))))))
|
||||
(log-ocm-debug "finished reduce. row indexes = ~v" reduced-row-indexes)
|
||||
reduced-row-indexes)
|
||||
|
||||
|
||||
(define (reduce2 row-indices col-indices matrix-proc entry->value)
|
||||
(let find-survivors ([rows row-indices][survivors empty])
|
||||
(cond
|
||||
[(vector-empty? rows) (list->vector (reverse survivors))]
|
||||
[else
|
||||
(define challenger-row (vector-ref rows 0))
|
||||
(cond
|
||||
;; no survivors yet, so push first row and keep going
|
||||
[(empty? survivors) (find-survivors (vector-cdr rows) (cons challenger-row survivors))]
|
||||
[else
|
||||
(define index-of-last-survivor (sub1 (length survivors)))
|
||||
(define col-head (vector-ref col-indices index-of-last-survivor))
|
||||
(define-syntax-rule (test-function r) (entry->value (matrix-proc r col-head)))
|
||||
(cond
|
||||
;; this is the challenge: is the head cell of challenger a new minimum?
|
||||
;; use < not <=, so the recorded winner is the earliest row with the new minimum, not the latest row
|
||||
;; if yes, challenger wins. pop element from stack, and let challenger try again (= leave rows alone)
|
||||
[(< (test-function challenger-row) (test-function (car survivors))) (find-survivors rows (cdr survivors))]
|
||||
|
||||
;; if not, challenger lost.
|
||||
;; If we're in the last column, ignore the loser by recurring on the same values
|
||||
[(= col-head (vector-last col-indices)) (find-survivors (vector-cdr rows) survivors)]
|
||||
|
||||
;; otherwise challenger lost and we're not in last column,
|
||||
;; so add challenger to survivor stack
|
||||
[else (find-survivors (vector-cdr rows) (cons challenger-row survivors))])])])))
|
||||
|
||||
|
||||
|
||||
(define (make-minimum value row-idx)
|
||||
(define ht (make-hash))
|
||||
(! ht 'value value)
|
||||
(! ht 'row-idx row-idx)
|
||||
ht)
|
||||
|
||||
;; Interpolate phase: in the minima hash, add results for even rows
|
||||
|
||||
(define-syntax-rule (vector-last v)
|
||||
(vector-ref v (sub1 (vector-length v))))
|
||||
|
||||
(define (interpolate minima row-indices col-indices matrix-proc entry->value)
|
||||
;(hash? vector? vector? procedure? procedure? . -> . hash?)
|
||||
(for ([col-idx (in-range 0 (vector-length col-indices) 2)]) ;; even-col-indices
|
||||
(define col (vector-ref col-indices col-idx))
|
||||
(define idx-of-last-row
|
||||
(if (= col-idx (sub1 (vector-length col-indices)))
|
||||
(vector-last row-indices)
|
||||
(: (hash-ref minima (vector-ref col-indices (add1 col-idx))) 'row-idx)))
|
||||
|
||||
(define smallest-value-entry
|
||||
(vector-argmin (compose1 entry->value car)
|
||||
(for/vector ([row-idx (in-list (dropf-right (vector->list row-indices) (negate (curry = idx-of-last-row))))])
|
||||
(list (matrix-proc row-idx col) row-idx))))
|
||||
|
||||
(! minima col (apply make-minimum smallest-value-entry)))
|
||||
minima)
|
||||
|
||||
(define (interpolate2 minima row-indices col-indices matrix-proc entry->value)
|
||||
(define idx-of-last-col (sub1 (vector-length col-indices)))
|
||||
(define (smallest-value-entry col idx-of-last-row)
|
||||
(argmin (compose1 entry->value car)
|
||||
(for/list ([row-idx (stop-after (in-vector row-indices) (curry = idx-of-last-row))])
|
||||
(list (matrix-proc row-idx col) row-idx))))
|
||||
|
||||
(for ([(col col-idx) (in-indexed col-indices)] #:when (even? col-idx))
|
||||
(define idx-of-last-row (if (= col-idx idx-of-last-col)
|
||||
(vector-last row-indices)
|
||||
(: (hash-ref minima (vector-ref col-indices (add1 col-idx))) 'row-idx)))
|
||||
(! minima col (apply make-minimum (smallest-value-entry col idx-of-last-row))))
|
||||
minima)
|
||||
|
||||
|
||||
#|
|
||||
Search for the minimum value in each column of a matrix.
|
||||
The return value is a dictionary mapping ColIndices to pairs
|
||||
(value,rowindex). We break ties in favor of earlier rows.
|
||||
|
||||
The matrix is defined implicitly as a function, passed
|
||||
as the third argument to this routine, where Matrix(i,j)
|
||||
gives the matrix value at row index i and column index j.
|
||||
The matrix must be concave, that is, satisfy the property
|
||||
Matrix(i,j) > Matrix(i',j) => Matrix(i,j') > Matrix(i',j')
|
||||
for every i<i' and j<j'; that is, in every submatrix of
|
||||
the input matrix, the positions of the column minima
|
||||
must be monotonically nondecreasing.
|
||||
|
||||
The rows and columns of the matrix are labeled by the indices
|
||||
given in order by the first two arguments. In most applications,
|
||||
these arguments can simply be integer ranges.
|
||||
|#
|
||||
|
||||
;; The return value `minima` is a hash:
|
||||
;; the keys are col-indices (integers)
|
||||
;; the values are pairs of (value row-index).
|
||||
(require rackunit)
|
||||
(define (concave-minima row-indices [col-indices null] [matrix-proc (make-caching-proc identity)] [entry->value identity])
|
||||
;((vector?) ((or/c #f vector?) procedure? procedure?) . ->* . hash?)
|
||||
(define reduce-proc reduce2)
|
||||
(define interpolate-proc interpolate2)
|
||||
(if (= 0 (vector-length col-indices))
|
||||
(make-hash)
|
||||
(let ([row-indices (reduce-proc row-indices col-indices matrix-proc entry->value)])
|
||||
(define odd-column-minima (concave-minima row-indices (vector-odd-elements col-indices) matrix-proc entry->value))
|
||||
(interpolate-proc odd-column-minima row-indices col-indices matrix-proc entry->value))))
|
||||
|
||||
|
||||
#|
|
||||
Online concave minimization algorithm of Galil and Park.
|
||||
|
||||
OnlineConcaveMinima(Matrix,initial) creates a sequence of pairs
|
||||
(self.value(j),self.index(j)), where
|
||||
self.value(0) = initial,
|
||||
self.value(j) = min { Matrix(i,j) | i < j } for j > 0,
|
||||
and where self.index(j) is the value of j that provides the minimum.
|
||||
Matrix(i,j) must be concave, in the same sense as for ConcaveMinima.
|
||||
|
||||
We never call Matrix(i,j) until value(i) has already been computed,
|
||||
so that the Matrix function may examine previously computed values.
|
||||
Calling value(i) for an i that has not yet been computed forces
|
||||
the sequence to be continued until the desired index is reached.
|
||||
Calling iter(self) produces a sequence of (value,index) pairs.
|
||||
|
||||
Matrix(i,j) should always return a value, rather than raising an
|
||||
exception, even for j larger than the range we expect to compute.
|
||||
If j is out of range, a suitable value to return that will not
|
||||
violate concavity is Matrix(i,j) = -i. It will not work correctly
|
||||
to return a flag value such as None for large j, because the ties
|
||||
formed by the equalities among such flags may violate concavity.
|
||||
|#
|
||||
|
||||
;; Online Concave Minima object
|
||||
;(struct $ocm (values indices finished matrix-proc base tentative) #:transparent #:mutable)
|
||||
|
||||
;; State used by self.value(), self.index(), and iter(self) =
|
||||
;; $ocm-values, $ocm-indices, $ocm-finished
|
||||
|
||||
#|
|
||||
State used by the internal algorithm:
|
||||
$ocm-matrix, $ocm-base, $ocm-tentative
|
||||
|
||||
We allow self._values to be nonempty for indices > finished,
|
||||
keeping invariant that
|
||||
(1) self._values[i] = Matrix(self._indices[i], i),
|
||||
(2) if the eventual correct value of self.index(i) < base,
|
||||
then self._values[i] is nonempty and correct.
|
||||
|
||||
In addition, we keep a column index self._tentative, such that
|
||||
(3) if i <= tentative, and the eventual correct value of
|
||||
self.index(i) <= finished, then self._values[i] is correct.
|
||||
|#
|
||||
|
||||
(define no-value 'none)
|
||||
|
||||
(define-syntax-rule (: hashtable key)
|
||||
(hash-ref hashtable key))
|
||||
|
||||
(define-syntax-rule (! hashtable key value)
|
||||
(hash-set! hashtable key value))
|
||||
|
||||
(define-syntax-rule (ocm-ref ocm key)
|
||||
(vector-ref ocm key))
|
||||
|
||||
(define-syntax-rule (ocm-set! ocm key value)
|
||||
(vector-set! ocm key value))
|
||||
|
||||
(define o:min-values 0)
|
||||
(define o:min-row-indices 1)
|
||||
(define o:finished 2)
|
||||
(define o:matrix-proc 3)
|
||||
(define o:entry->value 4)
|
||||
(define o:base 5)
|
||||
(define o:tentative 6)
|
||||
|
||||
(define (make-ocm matrix-proc [initial-value 0][entry->value identity])
|
||||
(log-ocm-debug "making new ocm")
|
||||
(define ocm (make-vector 7))
|
||||
(ocm-set! ocm o:min-values (vector initial-value))
|
||||
(ocm-set! ocm o:min-row-indices (vector no-value))
|
||||
(ocm-set! ocm o:finished 0)
|
||||
(ocm-set! ocm o:matrix-proc (make-caching-proc matrix-proc))
|
||||
(ocm-set! ocm o:entry->value entry->value) ; for converting matrix values to an integer
|
||||
(ocm-set! ocm o:base 0)
|
||||
(ocm-set! ocm o:tentative 0)
|
||||
ocm)
|
||||
|
||||
|
||||
;; Return min { Matrix(i,j) | i < j }.
|
||||
(define (min-value ocm j)
|
||||
(if (< (ocm-ref ocm o:finished) j)
|
||||
(begin (advance! ocm) (min-value ocm j))
|
||||
(vector-ref (ocm-ref ocm o:min-values) j)))
|
||||
|
||||
;; Return argmin { Matrix(i,j) | i < j }.
|
||||
(define (min-index ocm j)
|
||||
(if (< (ocm-ref ocm o:finished) j)
|
||||
(begin (advance! ocm) (min-index ocm j))
|
||||
(vector-ref (ocm-ref ocm o:min-row-indices) j)))
|
||||
|
||||
;; Finish another value,index pair.
|
||||
(define (advance! ocm)
|
||||
(define next (add1 (ocm-ref ocm o:finished)))
|
||||
(log-ocm-debug "advance! ocm to next = ~a" (add1 (ocm-ref ocm o:finished)))
|
||||
(cond
|
||||
;; First case: we have already advanced past the previous tentative
|
||||
;; value. We make a new tentative value by applying ConcaveMinima
|
||||
;; to the largest square submatrix that fits under the base.
|
||||
[(> next (ocm-ref ocm o:tentative))
|
||||
(log-ocm-debug "advance: first case because next (~a) > tentative (~a)" next (ocm-ref ocm o:tentative))
|
||||
(define rows (list->vector (range (ocm-ref ocm o:base) next)))
|
||||
(ocm-set! ocm o:tentative (+ (ocm-ref ocm o:finished) (vector-length rows)))
|
||||
(define cols (list->vector (range next (add1 (ocm-ref ocm o:tentative)))))
|
||||
(define minima (concave-minima rows cols (ocm-ref ocm o:matrix-proc) (ocm-ref ocm o:entry->value)))
|
||||
(for ([col (in-vector cols)])
|
||||
(cond
|
||||
[(>= col (vector-length (ocm-ref ocm o:min-values)))
|
||||
(ocm-set! ocm o:min-values (vector-append-item (ocm-ref ocm o:min-values) (: (: minima col) 'value)))
|
||||
(ocm-set! ocm o:min-row-indices (vector-append-item (ocm-ref ocm o:min-row-indices) (: (: minima col) 'row-idx)))]
|
||||
[(< ((ocm-ref ocm o:entry->value) (: (: minima col) 'value)) ((ocm-ref ocm o:entry->value) (vector-ref (ocm-ref ocm o:min-values) col)))
|
||||
(ocm-set! ocm o:min-values (vector-set (ocm-ref ocm o:min-values) col (: (: minima col) 'value)))
|
||||
(ocm-set! ocm o:min-row-indices (vector-set (ocm-ref ocm o:min-row-indices) col (: (: minima col) 'row-idx)))]))
|
||||
(ocm-set! ocm o:finished next)]
|
||||
|
||||
[else
|
||||
;; Second case: the new column minimum is on the diagonal.
|
||||
;; All subsequent ones will be at least as low,
|
||||
;; so we can clear out all our work from higher rows.
|
||||
;; As in the fourth case, the loss of tentative is
|
||||
;; amortized against the increase in base.
|
||||
(define diag ((ocm-ref ocm o:matrix-proc) (sub1 next) next))
|
||||
(cond
|
||||
[(< ((ocm-ref ocm o:entry->value) diag) ((ocm-ref ocm o:entry->value) (vector-ref (ocm-ref ocm o:min-values) next)))
|
||||
(log-ocm-debug "advance: second case because column minimum is on the diagonal")
|
||||
(ocm-set! ocm o:min-values (vector-set (ocm-ref ocm o:min-values) next diag))
|
||||
(ocm-set! ocm o:min-row-indices (vector-set (ocm-ref ocm o:min-row-indices) next (sub1 next)))
|
||||
(ocm-set! ocm o:base (sub1 next))
|
||||
(ocm-set! ocm o:tentative next)
|
||||
(ocm-set! ocm o:finished next)]
|
||||
|
||||
;; Third case: row i-1 does not supply a column minimum in
|
||||
;; any column up to tentative. We simply advance finished
|
||||
;; while maintaining the invariant.
|
||||
[(>= ((ocm-ref ocm o:entry->value) ((ocm-ref ocm o:matrix-proc) (sub1 next) (ocm-ref ocm o:tentative)))
|
||||
((ocm-ref ocm o:entry->value) (vector-ref (ocm-ref ocm o:min-values) (ocm-ref ocm o:tentative))))
|
||||
(log-ocm-debug "advance: third case because row i-1 does not suppply a column minimum")
|
||||
(ocm-set! ocm o:finished next)]
|
||||
|
||||
;; Fourth and final case: a new column minimum at self._tentative.
|
||||
;; This allows us to make progress by incorporating rows
|
||||
;; prior to finished into the base. The base invariant holds
|
||||
;; because these rows cannot supply any later column minima.
|
||||
;; The work done when we last advanced tentative (and undone by
|
||||
;; this step) can be amortized against the increase in base.
|
||||
[else
|
||||
(log-ocm-debug "advance: fourth case because new column minimum")
|
||||
(ocm-set! ocm o:base (sub1 next))
|
||||
(ocm-set! ocm o:tentative next)
|
||||
(ocm-set! ocm o:finished next)])]))
|
||||
|
||||
(define (print ocm)
|
||||
(displayln (ocm-ref ocm o:min-values))
|
||||
(displayln (ocm-ref ocm o:min-row-indices)))
|
||||
|
||||
(define (smawky? m)
|
||||
(define (position-of-minimum xs)
|
||||
;; put each element together with its list index
|
||||
(let ([xs (map cons (range (length xs)) xs)])
|
||||
;; find the first one with the min value, and grab the list index
|
||||
(car (argmin cdr (filter (compose1 not negative? cdr) xs)))))
|
||||
;; tests if penalty matrix is monotone for non-negative values.
|
||||
(define increasing-minima? (apply <= (map position-of-minimum m)))
|
||||
(define monotone?
|
||||
(for*/and ([ridx (in-range 1 (length m))]
|
||||
[cidx (in-range (sub1 (length (car m))))])
|
||||
(let* ([prev-row (list-ref m (sub1 ridx))]
|
||||
[row (list-ref m ridx)]
|
||||
[a (list-ref prev-row cidx)]
|
||||
[b (list-ref prev-row (add1 cidx))]
|
||||
[c (list-ref row cidx)]
|
||||
[d (list-ref row (add1 cidx))])
|
||||
(if (andmap (compose1 not negative?) (list a b c d)) ;; smawk disregards negative values
|
||||
(cond
|
||||
[(< c d) (if (< a b) #t (error (format "Submatrix ~a not monotone in ~a" (list (list a b) (list c d)) m)))]
|
||||
[(= c d) (if (<= a b) #t (error (format "Submatrix ~a not monotone in ~a" (list (list a b) (list c d)) m)))]
|
||||
[else #t])
|
||||
#t))))
|
||||
(and increasing-minima? monotone?))
|
||||
|
||||
|
||||
(module+ test
|
||||
|
||||
(require rackunit)
|
||||
|
||||
|
||||
(define m '((25 42 57 78 90 103 123 142 151)
|
||||
(21 35 48 65 76 85 105 123 130)
|
||||
(13 26 35 51 58 67 86 100 104)
|
||||
(10 20 28 42 48 56 75 86 88)
|
||||
(20 29 33 44 49 55 73 82 80)
|
||||
(13 21 24 35 39 44 59 65 59)
|
||||
(19 25 28 38 42 44 57 61 52)
|
||||
(35 37 40 48 48 49 62 62 49)
|
||||
(37 36 37 42 39 39 51 50 37)
|
||||
(41 39 37 42 35 33 44 43 29)
|
||||
(58 56 54 55 47 41 50 47 29)
|
||||
(66 64 61 61 51 44 52 45 24)
|
||||
(82 76 72 70 56 49 55 46 23)
|
||||
(99 91 83 80 63 56 59 46 20)
|
||||
(124 116 107 100 80 71 72 58 28)
|
||||
(133 125 113 106 86 75 74 59 25)
|
||||
(156 146 131 120 97 84 80 65 31)
|
||||
(178 164 146 135 110 96 92 73 39)))
|
||||
(define m2 (apply map list m))
|
||||
(check-true (smawky? m))
|
||||
(check-true (smawky? m2))
|
||||
;; proc must return a value even for out-of-bounds i and j
|
||||
(define (simple-proc i j) (with-handlers [(exn:fail? (λ(exn) (* -1 i)))]
|
||||
(list-ref (list-ref m i) j)))
|
||||
(define (simple-proc2 i j) (with-handlers [(exn:fail? (λ(exn) (* -1 i)))]
|
||||
(list-ref (list-ref m2 i) j)))
|
||||
(check-equal? (simple-proc 0 2) 57) ; 0th row, 2nd col
|
||||
(check-equal? (simple-proc2 2 0) 57) ; flipped
|
||||
(define o (make-ocm simple-proc))
|
||||
(define row-indices (list->vector (range (length m))))
|
||||
(define col-indices (list->vector (range (length (car m)))))
|
||||
(define result (concave-minima row-indices col-indices simple-proc identity))
|
||||
(check-equal?
|
||||
(for/list ([j (in-vector col-indices)])
|
||||
(define h (hash-ref result j))
|
||||
(list (hash-ref h 'value) (hash-ref h 'row-idx)))
|
||||
'((10 3) (20 3) (24 5) (35 5) (35 9) (33 9) (44 9) (43 9) (20 13))) ; checked against SMAWK.py
|
||||
(check-equal?
|
||||
(for/list ([j (in-vector col-indices)])
|
||||
(list (min-value o j) (min-index o j)))
|
||||
'((0 none) (42 0) (48 1) (51 2) (48 3) (55 4) (59 5) (61 6) (49 7))) ; checked against SMAWK.py
|
||||
|
||||
(define o2 (make-ocm simple-proc2))
|
||||
(define row-indices2 (list->vector (range (length m2))))
|
||||
(define col-indices2 (list->vector (range (length (car m2)))))
|
||||
(define result2 (concave-minima row-indices2 col-indices2 simple-proc2 identity))
|
||||
(check-equal?
|
||||
(for/list ([j (in-vector col-indices2)])
|
||||
(define h (hash-ref result2 j))
|
||||
(list (hash-ref h 'value) (hash-ref h 'row-idx)))
|
||||
'((25 0) (21 0) (13 0) (10 0) (20 0) (13 0) (19 0) (35 0) (36 1) (29 8) (29 8) (24 8) (23 8) (20 8) (28 8) (25 8) (31 8) (39 8))) ; checked against SMAWK.py
|
||||
(check-equal?
|
||||
(for/list ([j (in-vector col-indices2)])
|
||||
(list (min-value o2 j) (min-index o2 j)))
|
||||
'((0 none) (21 0) (13 0) (10 0) (20 0) (13 0) (19 0) (35 0) (36 1) (29 8) (-9 9) (-10 10) (-11 11) (-12 12) (-13 13) (-14 14) (-15 15) (-16 16))) ; checked against SMAWK.py
|
||||
|
||||
)
|
||||
@ -1,192 +0,0 @@
|
||||
"""SMAWK.py
|
||||
|
||||
Totally monotone matrix searching algorithms.
|
||||
|
||||
The offline algorithm in ConcaveMinima is from Agarwal, Klawe, Moran,
|
||||
Shor, and Wilbur, Geometric applications of a matrix searching algorithm,
|
||||
Algorithmica 2, pp. 195-208 (1987).
|
||||
|
||||
The online algorithm in OnlineConcaveMinima is from Galil and Park,
|
||||
A linear time algorithm for concave one-dimensional dynamic programming,
|
||||
manuscript, 1989, which simplifies earlier work on the same problem
|
||||
by Wilbur (J. Algorithms 1988) and Eppstein (J. Algorithms 1990).
|
||||
|
||||
D. Eppstein, March 2002, significantly revised August 2005
|
||||
"""
|
||||
|
||||
def ConcaveMinima(RowIndices,ColIndices,Matrix):
|
||||
"""
|
||||
Search for the minimum value in each column of a matrix.
|
||||
The return value is a dictionary mapping ColIndices to pairs
|
||||
(value,rowindex). We break ties in favor of earlier rows.
|
||||
|
||||
The matrix is defined implicitly as a function, passed
|
||||
as the third argument to this routine, where Matrix(i,j)
|
||||
gives the matrix value at row index i and column index j.
|
||||
The matrix must be concave, that is, satisfy the property
|
||||
Matrix(i,j) > Matrix(i',j) => Matrix(i,j') > Matrix(i',j')
|
||||
for every i<i' and j<j'; that is, in every submatrix of
|
||||
the input matrix, the positions of the column minima
|
||||
must be monotonically nondecreasing.
|
||||
|
||||
The rows and columns of the matrix are labeled by the indices
|
||||
given in order by the first two arguments. In most applications,
|
||||
these arguments can simply be integer ranges.
|
||||
"""
|
||||
|
||||
# Base case of recursion
|
||||
if not ColIndices: return {}
|
||||
|
||||
# Reduce phase: make number of rows at most equal to number of cols
|
||||
stack = []
|
||||
for r in RowIndices:
|
||||
while len(stack) >= 1 and \
|
||||
Matrix(stack[-1], ColIndices[len(stack)-1]) \
|
||||
> Matrix(r, ColIndices[len(stack)-1]):
|
||||
stack.pop()
|
||||
if len(stack) != len(ColIndices):
|
||||
stack.append(r)
|
||||
RowIndices = stack
|
||||
|
||||
# Recursive call to search for every odd column
|
||||
minima = ConcaveMinima(RowIndices,
|
||||
[ColIndices[i] for i in range(1,len(ColIndices),2)],
|
||||
Matrix)
|
||||
|
||||
# Go back and fill in the even rows
|
||||
r = 0
|
||||
for c in range(0,len(ColIndices),2):
|
||||
col = ColIndices[c]
|
||||
row = RowIndices[r]
|
||||
if c == len(ColIndices) - 1:
|
||||
lastrow = RowIndices[-1]
|
||||
else:
|
||||
lastrow = minima[ColIndices[c+1]][1]
|
||||
pair = (Matrix(row,col),row)
|
||||
while row != lastrow:
|
||||
r += 1
|
||||
row = RowIndices[r]
|
||||
pair = min(pair,(Matrix(row,col),row))
|
||||
minima[col] = pair
|
||||
|
||||
return minima
|
||||
|
||||
class OnlineConcaveMinima:
|
||||
"""
|
||||
Online concave minimization algorithm of Galil and Park.
|
||||
|
||||
OnlineConcaveMinima(Matrix,initial) creates a sequence of pairs
|
||||
(self.value(j),self.index(j)), where
|
||||
self.value(0) = initial,
|
||||
self.value(j) = min { Matrix(i,j) | i < j } for j > 0,
|
||||
and where self.index(j) is the value of j that provides the minimum.
|
||||
Matrix(i,j) must be concave, in the same sense as for ConcaveMinima.
|
||||
|
||||
We never call Matrix(i,j) until value(i) has already been computed,
|
||||
so that the Matrix function may examine previously computed values.
|
||||
Calling value(i) for an i that has not yet been computed forces
|
||||
the sequence to be continued until the desired index is reached.
|
||||
Calling iter(self) produces a sequence of (value,index) pairs.
|
||||
|
||||
Matrix(i,j) should always return a value, rather than raising an
|
||||
exception, even for j larger than the range we expect to compute.
|
||||
If j is out of range, a suitable value to return that will not
|
||||
violate concavity is Matrix(i,j) = -i. It will not work correctly
|
||||
to return a flag value such as None for large j, because the ties
|
||||
formed by the equalities among such flags may violate concavity.
|
||||
"""
|
||||
|
||||
def __init__(self,Matrix,initial):
|
||||
"""Initialize a OnlineConcaveMinima object."""
|
||||
|
||||
# State used by self.value(), self.index(), and iter(self)
|
||||
self._values = [initial] # tentative solution values...
|
||||
self._indices = [None] # ...and their indices
|
||||
self._finished = 0 # index of last non-tentative value
|
||||
|
||||
# State used by the internal algorithm
|
||||
#
|
||||
# We allow self._values to be nonempty for indices > finished,
|
||||
# keeping invariant that
|
||||
# (1) self._values[i] = Matrix(self._indices[i], i),
|
||||
# (2) if the eventual correct value of self.index(i) < base,
|
||||
# then self._values[i] is nonempty and correct.
|
||||
#
|
||||
# In addition, we keep a column index self._tentative, such that
|
||||
# (3) if i <= tentative, and the eventual correct value of
|
||||
# self.index(i) <= finished, then self._values[i] is correct.
|
||||
#
|
||||
self._matrix = Matrix
|
||||
self._base = 0
|
||||
self._tentative = 0
|
||||
|
||||
def __str__(self):
|
||||
return "%s" % self._values
|
||||
|
||||
def __iter__(self):
|
||||
"""Loop through (value,index) pairs."""
|
||||
i = 0
|
||||
while True:
|
||||
yield self.value(i),self.index(i)
|
||||
i += 1
|
||||
|
||||
def value(self,j):
|
||||
"""Return min { Matrix(i,j) | i < j }."""
|
||||
while self._finished < j:
|
||||
self._advance()
|
||||
return self._values[j]
|
||||
|
||||
def index(self,j):
|
||||
"""Return argmin { Matrix(i,j) | i < j }."""
|
||||
while self._finished < j:
|
||||
self._advance()
|
||||
return self._indices[j]
|
||||
|
||||
def _advance(self):
|
||||
"""Finish another value,index pair."""
|
||||
# First case: we have already advanced past the previous tentative
|
||||
# value. We make a new tentative value by applying ConcaveMinima
|
||||
# to the largest square submatrix that fits under the base.
|
||||
i = self._finished + 1
|
||||
if i > self._tentative:
|
||||
rows = range(self._base,self._finished+1)
|
||||
self._tentative = self._finished+len(rows)
|
||||
cols = range(self._finished+1,self._tentative+1)
|
||||
minima = ConcaveMinima(rows,cols,self._matrix)
|
||||
for col in cols:
|
||||
if col >= len(self._values):
|
||||
self._values.append(minima[col][0])
|
||||
self._indices.append(minima[col][1])
|
||||
elif minima[col][0] < self._values[col]:
|
||||
self._values[col],self._indices[col] = minima[col]
|
||||
self._finished = i
|
||||
return
|
||||
|
||||
# Second case: the new column minimum is on the diagonal.
|
||||
# All subsequent ones will be at least as low,
|
||||
# so we can clear out all our work from higher rows.
|
||||
# As in the fourth case, the loss of tentative is
|
||||
# amortized against the increase in base.
|
||||
diag = self._matrix(i-1,i)
|
||||
if diag < self._values[i]:
|
||||
self._values[i] = diag
|
||||
self._indices[i] = self._base = i-1
|
||||
self._tentative = self._finished = i
|
||||
return
|
||||
|
||||
# Third case: row i-1 does not supply a column minimum in
|
||||
# any column up to tentative. We simply advance finished
|
||||
# while maintaining the invariant.
|
||||
if self._matrix(i-1,self._tentative) >= self._values[self._tentative]:
|
||||
self._finished = i
|
||||
return
|
||||
|
||||
# Fourth and final case: a new column minimum at self._tentative.
|
||||
# This allows us to make progress by incorporating rows
|
||||
# prior to finished into the base. The base invariant holds
|
||||
# because these rows cannot supply any later column minima.
|
||||
# The work done when we last advanced tentative (and undone by
|
||||
# this step) can be amortized against the increase in base.
|
||||
self._base = i-1
|
||||
self._tentative = self._finished = i
|
||||
return
|
||||
Binary file not shown.
@ -1,66 +0,0 @@
|
||||
import SMAWK
|
||||
|
||||
m1 = [
|
||||
[25, 42, 57, 78, 90, 103, 123, 142, 151],
|
||||
[21, 35, 48, 65, 76, 85, 105, 123, 130],
|
||||
[13, 26, 35, 51, 58, 67, 86, 100, 104],
|
||||
[10, 20, 28, 42, 48, 56, 75, 86, 88],
|
||||
[20, 29, 33, 44, 49, 55, 73, 82, 80],
|
||||
[13, 21, 24, 35, 39, 44, 59, 65, 59],
|
||||
[19, 25, 28, 38, 42, 44, 57, 61, 52],
|
||||
[35, 37, 40, 48, 48, 49, 62, 62, 49],
|
||||
[37, 36, 37, 42, 39, 39, 51, 50, 37],
|
||||
[41, 39, 37, 42, 35, 33, 44, 43, 29],
|
||||
[58, 56, 54, 55, 47, 41, 50, 47, 29],
|
||||
[66, 64, 61, 61, 51, 44, 52, 45, 24],
|
||||
[82, 76, 72, 70, 56, 49, 55, 46, 23],
|
||||
[99, 91, 83, 80, 63, 56, 59, 46, 20],
|
||||
[124, 116, 107, 100, 80, 71, 72, 58, 28],
|
||||
[133, 125, 113, 106, 86, 75, 74, 59, 25],
|
||||
[156, 146, 131, 120, 97, 84, 80, 65, 31],
|
||||
[178, 164, 146, 135, 110, 96, 92, 73, 39]]
|
||||
|
||||
|
||||
num_rows = len(m1)
|
||||
row_indices = range(num_rows)
|
||||
num_cols = len(m1[0])
|
||||
col_indices = range(num_cols)
|
||||
|
||||
|
||||
def matrix_func1(i, j):
|
||||
try:
|
||||
return m1[i][j]
|
||||
except:
|
||||
return -1 * i
|
||||
|
||||
def matrix_func2(i, j):
|
||||
try:
|
||||
return m1[j][i]
|
||||
except:
|
||||
return -1 * i
|
||||
|
||||
|
||||
cm_hash = SMAWK.ConcaveMinima(row_indices, col_indices, matrix_func1)
|
||||
cm_hash2 = SMAWK.ConcaveMinima(col_indices, row_indices, matrix_func2)
|
||||
|
||||
print cm_hash2
|
||||
|
||||
'''
|
||||
{0: (10, 3), 1: (20, 3), 2: (24, 5), 3: (35, 5), 4: (35, 9), 5: (33, 9), 6: (44, 9), 7: (43, 9), 8: (20, 13)}
|
||||
'''
|
||||
|
||||
ocm = SMAWK.OnlineConcaveMinima(matrix_func1, 0)
|
||||
ocm2 = SMAWK.OnlineConcaveMinima(matrix_func2, 0)
|
||||
|
||||
ocm_hash = dict()
|
||||
for j in col_indices:
|
||||
ocm_hash[j] = (ocm.value(j), ocm.index(j))
|
||||
|
||||
ocm_hash2 = dict()
|
||||
for j in row_indices:
|
||||
ocm_hash2[j] = (ocm2.value(j), ocm2.index(j))
|
||||
|
||||
print ocm_hash2
|
||||
|
||||
'''
|
||||
{0: (0, None), 1: (42, 0), 2: (48, 1), 3: (51, 2), 4: (48, 3), 5: (55, 4), 6: (59, 5), 7: (61, 6), 8: (49, 7)}'''
|
||||
@ -1,239 +0,0 @@
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base racket/syntax racket/string) racket/string racket/contract racket/serialize sugar/list racket/format racket/list sugar/debug sugar/coerce racket/bool racket/function sugar/unstable/string)
|
||||
(require "world.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
;; struct implementation
|
||||
|
||||
(serializable-struct quad (name attrs list) #:transparent
|
||||
#:methods gen:custom-write
|
||||
[(define write-proc (λ(b port mode)
|
||||
(display (format "(~a)" (string-join (filter-not void? (list
|
||||
(~a (quad-name b))
|
||||
(if (and (hash? (quad-attrs b)) (> (length (hash-keys (quad-attrs b))) 0)) (~v (flatten (hash->list (quad-attrs b)))) "#f")
|
||||
(if (> (length (quad-list b)) 0) (~a (string-join (map ~v (quad-list b)) " ")) (void)))) " ")) port)))]
|
||||
#:property prop:sequence (λ(q) (quad-list q)))
|
||||
|
||||
|
||||
|
||||
;; vector implementation
|
||||
#|
|
||||
(define (quad-name q) (vector-ref q 0))
|
||||
(define (quad-attrs q) (vector-ref q 1))
|
||||
(define (quad-list q) (vector-ref q 2))
|
||||
|
||||
(define (quad? x)
|
||||
(and (vector? x)
|
||||
(symbol? (quad-name x))
|
||||
(or (false? (quad-attrs x)) (hash? (quad-attrs x)))
|
||||
(list? (quad-list x))))
|
||||
|
||||
(define (quad name attrs xs)
|
||||
(vector name attrs xs))
|
||||
|#
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; hash implementation
|
||||
#|
|
||||
(define (quad-name q) (hash-ref q 'name))
|
||||
(define (quad-attrs q) (hash-ref q 'attrs))
|
||||
(define (quad-list q) (hash-ref q 'list))
|
||||
|
||||
(define (quad? x)
|
||||
(and (hash? x)
|
||||
(andmap (λ(k) (hash-has-key? x k)) (list 'name 'attrs 'list))
|
||||
(symbol? (quad-name x))
|
||||
(ormap (λ(pred) (pred (quad-attrs x))) (list false? hash?))
|
||||
(list? (quad-list x))))
|
||||
|
||||
(define (quad name attrs xs)
|
||||
(hash 'name name 'attrs attrs 'list xs))
|
||||
|#
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (quad-name? x) (symbol? x))
|
||||
(define (hashable-list? x) (and (list? x) (even? (length x))))
|
||||
(define (quad-attrs? x) (or (false? x) (hash? x)))
|
||||
(define (quad-list? x) (and (list? x) (andmap (λ(xi) (or (quad? xi) (and (string? xi) (< 0 (string-length xi))))) x)))
|
||||
(define (quads? x) (and (list? x) (andmap quad? x)))
|
||||
(define (lists-of-quads? x) (and (list? x) (andmap quads? x)))
|
||||
|
||||
(define quad= equal?)
|
||||
|
||||
(define token? quad?)
|
||||
|
||||
(define (quad/c x) (λ(x) (and (quad? x) (symbol? (quad-name x)) (hash? (quad-attrs x))
|
||||
(andmap (λ(xi) (or (quad/c xi) (string? xi))) (quad-list x)))))
|
||||
|
||||
(define quad-attr-ref
|
||||
(case-lambda
|
||||
[(q key)
|
||||
(if (quad-attrs q)
|
||||
(hash-ref (quad-attrs q) key)
|
||||
(error 'quad-attr-ref (format "no attrs in quad ~a" q)))]
|
||||
[(q key default)
|
||||
(if (quad-attrs q)
|
||||
(hash-ref (quad-attrs q) key default)
|
||||
default)]))
|
||||
|
||||
(define-syntax (quad-attr-ref/parameter stx)
|
||||
(syntax-case stx ()
|
||||
[(_ q key)
|
||||
(with-syntax ([world:key-default (format-id stx "~a-default" (string-trim (symbol->string (syntax->datum #'key)) "-key"))])
|
||||
#'(quad-attr-ref q key (world:key-default)))]))
|
||||
|
||||
|
||||
(define (quad-has-attr? q key)
|
||||
(define qa (quad-attrs q))
|
||||
(and qa (hash-has-key? qa key)))
|
||||
|
||||
(define-syntax (define-quad-list-function stx)
|
||||
(syntax-case stx ()
|
||||
[(_ proc)
|
||||
(with-syntax ([quad-proc (format-id stx "quad-~a" #'proc)])
|
||||
#'(define (quad-proc q) (proc (quad-list q))))]))
|
||||
|
||||
(define-quad-list-function first)
|
||||
(define-quad-list-function car)
|
||||
(define-quad-list-function cdr)
|
||||
(define-quad-list-function last)
|
||||
(define (quad-cons item q)
|
||||
(quad (quad-name q) (quad-attrs q) (cons item (quad-list q))))
|
||||
|
||||
(define-syntax-rule (quad-ref q r)
|
||||
(list-ref (quad-list q) r))
|
||||
|
||||
(define (quad-ends-with? q str)
|
||||
(quad? string? . -> . boolean?)
|
||||
(cond
|
||||
[(not (empty? (quad-list q)))
|
||||
(define last-item (last (quad-list q)))
|
||||
(cond
|
||||
[(string? last-item) (ends-with? last-item str)]
|
||||
[(quad? last-item) (quad-ends-with? last-item str)])]
|
||||
[else #f]))
|
||||
|
||||
|
||||
(define (quad-append q new-item)
|
||||
(quad? (or/c quad? string?) . -> . quad?)
|
||||
(quad (quad-name q) (quad-attrs q) (append (quad-list q) (list new-item))))
|
||||
|
||||
(define (quad->string x)
|
||||
(quad? . -> . string?)
|
||||
(cond
|
||||
[(quad? x) (string-append* (map quad->string (quad-list x)))]
|
||||
[(string? x) x]
|
||||
[else ""]))
|
||||
|
||||
(define-syntax-rule (report-quadstring q)
|
||||
(begin
|
||||
(report (quad->string q) 'q)
|
||||
q))
|
||||
|
||||
(define cannot-be-common-attrs '(width x y page)) ;; todo: how to specify these better? this-* prefix?
|
||||
|
||||
;; make this a macro because qs-in is often huge
|
||||
;; and the macro avoids allocation + garbage collection
|
||||
(define attr-missing (gensym))
|
||||
(define (gather-common-attrs qs)
|
||||
(let loop ([qs qs]
|
||||
[common-attrs (if (quad-attrs (car qs))
|
||||
(for/list ([kv-pair (in-hash-pairs (quad-attrs (car qs)))]
|
||||
#:unless (member (car kv-pair) cannot-be-common-attrs))
|
||||
kv-pair)
|
||||
empty)])
|
||||
(cond
|
||||
[(empty? common-attrs) empty]
|
||||
[(empty? qs) (flatten common-attrs)]
|
||||
[else (loop (cdr qs)
|
||||
(filter (λ(ca) (equal? (quad-attr-ref (car qs) (car ca) attr-missing) (cdr ca)))
|
||||
common-attrs))])))
|
||||
|
||||
|
||||
(define-syntax (define-box-type stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id)
|
||||
(with-syntax ([id? (format-id #'id "~a?" #'id)]
|
||||
[ids? (format-id #'id "~as?" #'id)]
|
||||
[lists-of-ids? (format-id #'id "list-of-~as?" #'id)]
|
||||
[quads->id (format-id #'id "quads->~a" #'id)]
|
||||
[inline/quads->id (format-id #'id "inline/quads->~a" #'id)])
|
||||
#'(begin
|
||||
;; quad predicate - ok to be relaxed here if we're strict when making the struct
|
||||
(define (id? x)
|
||||
(and (quad? x) (equal? (quad-name x) 'id)))
|
||||
;; quad constructor
|
||||
;; put contract here rather than on struct, because this is the main interface
|
||||
;; and this contract is more liberal.
|
||||
;; but don't put a separate contract on struct, because it's superfluous.
|
||||
(define (id [attrs empty] . xs)
|
||||
(() ((or/c quad-attrs? hashable-list?)) #:rest quad-list? . ->* . id?)
|
||||
(quad 'id (and attrs (if (hash? attrs) attrs (apply hash attrs))) xs))
|
||||
;; quad list predicate and list-of-list predicate.
|
||||
;; These are faster than the listof contract combinator.
|
||||
(define (ids? x)
|
||||
(and (list? x) (andmap id? x)))
|
||||
(define (lists-of-ids? x)
|
||||
(and (list? x) (andmap ids? x)))
|
||||
;; quad converter macro
|
||||
(define (quads->id qs)
|
||||
(apply id (gather-common-attrs qs) qs))))]))
|
||||
|
||||
|
||||
;; do not treat empty string as whitespace.
|
||||
;; throws off tests that rely on adjacency to positive whitespace.
|
||||
(define (whitespace? x [nbsp? #f])
|
||||
((any/c)(boolean?) . ->* . coerce/boolean?)
|
||||
(cond
|
||||
[(quad? x) (whitespace? (quad-list x) nbsp?)]
|
||||
[(string? x) (or (and (regexp-match #px"\\p{Zs}" x) ; Zs = unicode whitespace category
|
||||
(or nbsp? (not (regexp-match #px"\u00a0" x)))))] ; 00a0: nbsp
|
||||
[(list? x) (and (not (empty? x)) (andmap (curryr whitespace? nbsp?) x))] ; andmap returns #t for empty lists
|
||||
[else #f]))
|
||||
|
||||
(define (whitespace/nbsp? x)
|
||||
(whitespace? x #t))
|
||||
|
||||
|
||||
(define-syntax (define-break-type stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id)
|
||||
(with-syntax ([split-on-id-breaks (format-id #'id "split-on-~a-breaks" #'id)]
|
||||
[id-break (format-id #'id "~a-break" #'id)]
|
||||
[id-break? (format-id #'id "~a-break?" #'id)]
|
||||
[multi-id (format-id #'id "multi~a" #'id)]
|
||||
[multi-id? (format-id #'id "multi~a?" #'id)]
|
||||
[quads->multi-id (format-id #'id "quads->multi~a" #'id)])
|
||||
#'(begin
|
||||
(define-box-type id)
|
||||
(define-box-type id-break)
|
||||
(define-box-type multi-id)
|
||||
;; breaker
|
||||
(define (split-on-id-breaks x)
|
||||
(quads? . -> . lists-of-quads?)
|
||||
;; omit leading & trailing whitespace, because they're superfluous next to a break
|
||||
(map (curryr trimf whitespace?) (filter-split x id-break?)))))]))
|
||||
|
||||
(define-box-type box)
|
||||
|
||||
(define-break-type word)
|
||||
(define (word-string c) (car (quad-list c)))
|
||||
|
||||
(define-box-type spacer)
|
||||
(define-box-type kern)
|
||||
(define-box-type optical-kern)
|
||||
(define-box-type flag)
|
||||
(define-box-type doc)
|
||||
(define-box-type input)
|
||||
(define-box-type piece)
|
||||
(define-box-type run)
|
||||
|
||||
(define-break-type page)
|
||||
(define-break-type column)
|
||||
(define-break-type block)
|
||||
(define-break-type line)
|
||||
|
||||
(define (->input q) (input empty q))
|
||||
(define coerce/input? (make-coercion-contract input))
|
||||
|
||||
@ -1,10 +0,0 @@
|
||||
#lang racket/base
|
||||
|
||||
(require "typeset.rkt" "world.rkt" "quick-sample.rkt"
|
||||
"render.rkt" racket/class quad/quads)
|
||||
(parameterize ([world:quality-default world:draft-quality])
|
||||
(displayln "Untyped Quad")
|
||||
(displayln "Typesetting:")
|
||||
(define to (time (typeset (dynamic-require "foo.rkt" 'ts))))
|
||||
(displayln "PDF rendering:")
|
||||
(time (send (new pdf-renderer%) render-to-file to "quick-test-untyped.pdf")))
|
||||
@ -1,106 +0,0 @@
|
||||
#lang racket/base
|
||||
(require racket/class racket/contract sugar/debug sugar/cache racket/list racket/file racket/draw data/gvector)
|
||||
(require "utils.rkt" "quads.rkt" "world.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define abstract-renderer%
|
||||
#;(class/c [render (quad? . ->m . any/c)]
|
||||
[render-element (quad? . ->m . quad?)])
|
||||
|
||||
(class object%
|
||||
(super-new)
|
||||
|
||||
(define renderable-quads '(word box))
|
||||
|
||||
;; hash implementation
|
||||
(define/public (render0 doc-quad)
|
||||
(finalize
|
||||
(let ([rendering-input (flatten-quad (setup doc-quad))])
|
||||
(define page-quad-hash (make-hash))
|
||||
(for ([q (in-list rendering-input)])
|
||||
(when (member (quad-name q) renderable-quads)
|
||||
(hash-update! page-quad-hash (quad-attr-ref q world:page-key) (λ(v) (cons q v)) null)))
|
||||
(map (λ(k) (render-page (hash-ref page-quad-hash k))) (sort (hash-keys page-quad-hash) <)))))
|
||||
|
||||
|
||||
;; gvector implementation
|
||||
(define/public (render doc-quad)
|
||||
(finalize
|
||||
(let ([rendering-input (flatten-quad (setup doc-quad))])
|
||||
(define page-quad-vector (make-gvector))
|
||||
(for ([q (in-list rendering-input)] #:when (member (quad-name q) renderable-quads))
|
||||
(define p (quad-attr-ref q world:page-key))
|
||||
(gvector-set! page-quad-vector p (cons q (gvector-ref page-quad-vector p null))))
|
||||
(for/list ([pq (in-gvector page-quad-vector)])
|
||||
(render-page pq)))))
|
||||
|
||||
|
||||
(define/public (render-element q)
|
||||
(cond
|
||||
[(word? q) (render-word q)]
|
||||
[else q]))
|
||||
|
||||
(define/public (setup q) q)
|
||||
(abstract render-page)
|
||||
(abstract render-word)
|
||||
(define/public (finalize q) q)))
|
||||
|
||||
|
||||
(define-syntax-rule (map/send method xs)
|
||||
(map (λ(x) (method x)) xs))
|
||||
|
||||
|
||||
(define pdf-renderer%
|
||||
(class abstract-renderer%
|
||||
(super-new)
|
||||
|
||||
(send* (current-ps-setup) (set-margin 0 0) (set-scaling 1.0 1.0))
|
||||
(define dc-output-port (open-output-bytes))
|
||||
(define dc (new pdf-dc% [interactive #f][use-paper-bbox #f][as-eps #f]
|
||||
[output dc-output-port]
|
||||
[width (world:paper-width-default)][height (world:paper-height-default)]))
|
||||
|
||||
(define/override (setup tx)
|
||||
(send* dc
|
||||
(start-doc "boing")
|
||||
(set-pen "black" 1 'solid)
|
||||
(set-brush "black" 'transparent)) ; no fill by default
|
||||
tx)
|
||||
|
||||
(inherit render-element)
|
||||
|
||||
(define/caching (make-font/caching font size style weight)
|
||||
(make-font #:face font #:size size #:style style #:weight weight))
|
||||
|
||||
(define/override-final (render-word w)
|
||||
(define word-font (quad-attr-ref/parameter w world:font-name-key))
|
||||
(define word-size (quad-attr-ref/parameter w world:font-size-key))
|
||||
(define word-style (quad-attr-ref/parameter w world:font-style-key))
|
||||
(define word-weight (quad-attr-ref/parameter w world:font-weight-key))
|
||||
(define word-color (quad-attr-ref/parameter w world:font-color-key))
|
||||
(define word-background (quad-attr-ref/parameter w world:font-background-key))
|
||||
(send dc set-font (make-font/caching word-font word-size word-style word-weight))
|
||||
(send dc set-text-foreground (send the-color-database find-color word-color))
|
||||
(define background-color (send the-color-database find-color word-background))
|
||||
(if background-color ; all invalid color-string values will return #f
|
||||
(send* dc (set-text-mode 'solid) (set-text-background background-color))
|
||||
(send dc set-text-mode 'transparent))
|
||||
|
||||
(define word-text (quad-car w))
|
||||
(send dc draw-text word-text (quad-attr-ref w world:x-position-key)
|
||||
;; we want to align by baseline rather than top of box
|
||||
;; thus, subtract ascent from y to put baseline at the y coordinate
|
||||
(- (quad-attr-ref w world:y-position-key) (quad-attr-ref w world:ascent-key 0)) #t))
|
||||
|
||||
(define/override-final (render-page elements)
|
||||
(send dc start-page)
|
||||
(map/send render-element (filter-not whitespace/nbsp? elements))
|
||||
(send dc end-page))
|
||||
|
||||
(define/override-final (finalize xs)
|
||||
(send dc end-doc)
|
||||
(get-output-bytes dc-output-port))
|
||||
|
||||
(define/public (render-to-file doc-quad path)
|
||||
(define result-bytes (send this render doc-quad))
|
||||
(display-to-file result-bytes path #:exists 'replace #:mode 'binary))))
|
||||
@ -1,4 +0,0 @@
|
||||
#lang typed/racket/base/no-check
|
||||
(require "quads.rkt" racket/file racket/string racket/function racket/list racket/include)
|
||||
(provide (all-defined-out))
|
||||
(include "samples-base.rktd")
|
||||
File diff suppressed because one or more lines are too long
@ -1,319 +0,0 @@
|
||||
/* See the beginning of "manual.css". */
|
||||
|
||||
/* Monospace: */
|
||||
|
||||
.RktIn, .RktRdr, .RktPn, .RktMeta,
|
||||
.RktMod, .RktKw, .RktVar, .RktSym,
|
||||
.RktRes, .RktOut, .RktCmt, .RktVal,
|
||||
.RktBlk, .RktErr {
|
||||
font-family: 'Source Code Pro', monospace;
|
||||
white-space: inherit;
|
||||
font-size: 1rem;
|
||||
}
|
||||
|
||||
/* this selctor grabs the first linked Racket symbol
|
||||
in a definition box (i.e., the symbol being defined) */
|
||||
a.RktValDef, a.RktStxDef, a.RktSymDef,
|
||||
span.RktValDef, span.RktStxDef, span.RktSymDef
|
||||
{
|
||||
font-size: 1.15rem;
|
||||
color: black;
|
||||
font-weight: 600;
|
||||
}
|
||||
|
||||
|
||||
.inheritedlbl {
|
||||
font-family: 'Fira', sans;
|
||||
}
|
||||
|
||||
.RBackgroundLabelInner {
|
||||
font-family: inherit;
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* Inherited methods, left margin */
|
||||
|
||||
.inherited {
|
||||
width: 95%;
|
||||
margin-top: 0.5em;
|
||||
text-align: left;
|
||||
background-color: inherit;
|
||||
}
|
||||
|
||||
.inherited td {
|
||||
font-size: 82%;
|
||||
padding-left: 0.5rem;
|
||||
line-height: 1.3;
|
||||
text-indent: 0;
|
||||
padding-right: 0;
|
||||
}
|
||||
|
||||
.inheritedlbl {
|
||||
font-style: normal;
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* Racket text styles */
|
||||
|
||||
.RktIn {
|
||||
color: #cc6633;
|
||||
background-color: #eee;
|
||||
}
|
||||
|
||||
.RktInBG {
|
||||
background-color: #eee;
|
||||
}
|
||||
|
||||
|
||||
.refcolumn .RktInBG {
|
||||
background-color: white;
|
||||
}
|
||||
|
||||
.RktRdr {
|
||||
}
|
||||
|
||||
.RktPn {
|
||||
color: #843c24;
|
||||
}
|
||||
|
||||
.RktMeta {
|
||||
color: black;
|
||||
}
|
||||
|
||||
.RktMod {
|
||||
color: inherit;
|
||||
}
|
||||
|
||||
.RktOpt {
|
||||
color: black;
|
||||
}
|
||||
|
||||
.RktKw {
|
||||
color: black;
|
||||
}
|
||||
|
||||
.RktErr {
|
||||
color: red;
|
||||
font-style: italic;
|
||||
font-weight: 400;
|
||||
}
|
||||
|
||||
.RktVar {
|
||||
position: relative;
|
||||
left: -1px; font-style: italic;
|
||||
color: #444;
|
||||
}
|
||||
|
||||
.SVInsetFlow .RktVar {
|
||||
font-weight: 400;
|
||||
color: #444;
|
||||
}
|
||||
|
||||
|
||||
.RktSym {
|
||||
color: inherit;
|
||||
}
|
||||
|
||||
|
||||
|
||||
.RktValLink, .RktStxLink, .RktModLink {
|
||||
text-decoration: none;
|
||||
color: #07A;
|
||||
font-weight: 500;
|
||||
font-size: 1rem;
|
||||
}
|
||||
|
||||
/* for syntax links within headings */
|
||||
h2 a.RktStxLink, h3 a.RktStxLink, h4 a.RktStxLink, h5 a.RktStxLink,
|
||||
h2 a.RktValLink, h3 a.RktValLink, h4 a.RktValLink, h5 a.RktValLink,
|
||||
h2 .RktSym, h3 .RktSym, h4 .RktSym, h5 .RktSym,
|
||||
h2 .RktMod, h3 .RktMod, h4 .RktMod, h5 .RktMod,
|
||||
h2 .RktVal, h3 .RktVal, h4 .RktVal, h5 .RktVal,
|
||||
h2 .RktPn, h3 .RktPn, h4 .RktPn, h5 .RktPn {
|
||||
color: #333;
|
||||
font-size: 1.65rem;
|
||||
font-weight: 400;
|
||||
}
|
||||
|
||||
.toptoclink .RktStxLink, .toclink .RktStxLink,
|
||||
.toptoclink .RktValLink, .toclink .RktValLink,
|
||||
.toptoclink .RktModLink, .toclink .RktModLink {
|
||||
color: inherit;
|
||||
}
|
||||
|
||||
.tocset .RktValLink, .tocset .RktStxLink, .tocset .RktModLink {
|
||||
color: black;
|
||||
font-weight: 400;
|
||||
font-size: 0.9rem;
|
||||
}
|
||||
|
||||
.tocset td a.tocviewselflink .RktValLink,
|
||||
.tocset td a.tocviewselflink .RktStxLink,
|
||||
.tocset td a.tocviewselflink .RktMod,
|
||||
.tocset td a.tocviewselflink .RktSym {
|
||||
font-weight: lighter;
|
||||
color: white;
|
||||
}
|
||||
|
||||
|
||||
.RktRes {
|
||||
color: #0000af;
|
||||
}
|
||||
|
||||
.RktOut {
|
||||
color: #960096;
|
||||
}
|
||||
|
||||
.RktCmt {
|
||||
color: #c2741f;
|
||||
}
|
||||
|
||||
.RktVal {
|
||||
color: #228b22;
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* Some inline styles */
|
||||
|
||||
.together { /* for definitions grouped together in one box */
|
||||
width: 100%;
|
||||
border-top: 2px solid white;
|
||||
}
|
||||
|
||||
tbody > tr:first-child > td > .together {
|
||||
border-top: 0px; /* erase border on first instance of together */
|
||||
}
|
||||
|
||||
.RktBlk {
|
||||
white-space: pre;
|
||||
text-align: left;
|
||||
}
|
||||
|
||||
.highlighted {
|
||||
font-size: 1rem;
|
||||
background-color: #fee;
|
||||
}
|
||||
|
||||
.defmodule {
|
||||
font-family: 'Source Code Pro';
|
||||
padding: 0.25rem 0.75rem 0.25rem 0.5rem;
|
||||
margin-bottom: 1rem;
|
||||
width: 100%;
|
||||
background-color: hsl(60, 29%, 94%);
|
||||
}
|
||||
|
||||
.defmodule a {
|
||||
color: #444;
|
||||
}
|
||||
|
||||
|
||||
.defmodule td span.hspace:first-child {
|
||||
position: absolute;
|
||||
width: 0;
|
||||
display: inline-block;
|
||||
}
|
||||
|
||||
.defmodule .RpackageSpec .Smaller,
|
||||
.defmodule .RpackageSpec .stt {
|
||||
font-size: 1rem;
|
||||
}
|
||||
|
||||
|
||||
.specgrammar {
|
||||
float: none;
|
||||
padding-left: 1em;
|
||||
}
|
||||
|
||||
|
||||
.RBibliography td {
|
||||
vertical-align: text-top;
|
||||
padding-top: 1em;
|
||||
}
|
||||
|
||||
.leftindent {
|
||||
margin-left: 2rem;
|
||||
margin-right: 0em;
|
||||
}
|
||||
|
||||
.insetpara {
|
||||
margin-left: 1em;
|
||||
margin-right: 1em;
|
||||
}
|
||||
|
||||
.SCodeFlow .Rfilebox {
|
||||
margin-left: -1em; /* see 17.2 of guide, module languages */
|
||||
}
|
||||
|
||||
.Rfiletitle {
|
||||
text-align: right;
|
||||
background-color: #eee;
|
||||
}
|
||||
|
||||
.SCodeFlow .Rfiletitle {
|
||||
border-top: 1px dotted gray;
|
||||
border-right: 1px dotted gray;
|
||||
}
|
||||
|
||||
|
||||
.Rfilename {
|
||||
border-top: 0;
|
||||
border-right: 0;
|
||||
padding-left: 0.5em;
|
||||
padding-right: 0.5em;
|
||||
background-color: inherit;
|
||||
}
|
||||
|
||||
.Rfilecontent {
|
||||
margin: 0.5em;
|
||||
}
|
||||
|
||||
.RpackageSpec {
|
||||
padding-right: 0;
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* For background labels */
|
||||
|
||||
.RBackgroundLabel {
|
||||
float: right;
|
||||
width: 0px;
|
||||
height: 0px;
|
||||
}
|
||||
|
||||
.RBackgroundLabelInner {
|
||||
position: relative;
|
||||
width: 25em;
|
||||
left: -25.5em;
|
||||
top: 0.20rem; /* sensitive to monospaced font choice */
|
||||
text-align: right;
|
||||
z-index: 0;
|
||||
font-weight: 300;
|
||||
font-family: 'Source Code Pro';
|
||||
font-size: 0.9rem;
|
||||
color: gray;
|
||||
}
|
||||
|
||||
|
||||
.RpackageSpec .Smaller {
|
||||
font-weight: 300;
|
||||
font-family: 'Source Code Pro';
|
||||
font-size: 0.9rem;
|
||||
}
|
||||
|
||||
.RForeground {
|
||||
position: relative;
|
||||
left: 0px;
|
||||
top: 0px;
|
||||
z-index: 1;
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* For section source modules & tags */
|
||||
|
||||
.RPartExplain {
|
||||
background: #eee;
|
||||
font-size: 0.9rem;
|
||||
margin-top: 0.2rem;
|
||||
padding: 0.2rem;
|
||||
text-align: left;
|
||||
}
|
||||
@ -1,98 +0,0 @@
|
||||
/* For the Racket manual style */
|
||||
|
||||
AddOnLoad(function() {
|
||||
/* Look for header elements that have x-source-module and x-part tag.
|
||||
For those elements, add a hidden element that explains how to
|
||||
link to the section, and set the element's onclick() to display
|
||||
the explanation. */
|
||||
var tag_names = ["h1", "h2", "h3", "h4", "h5"];
|
||||
for (var j = 0; j < tag_names.length; j++) {
|
||||
elems = document.getElementsByTagName(tag_names[j]);
|
||||
for (var i = 0; i < elems.length; i++) {
|
||||
var elem = elems.item(i);
|
||||
AddPartTitleOnClick(elem);
|
||||
}
|
||||
}
|
||||
})
|
||||
|
||||
function AddPartTitleOnClick(elem) {
|
||||
var mod_path = elem.getAttribute("x-source-module");
|
||||
var tag = elem.getAttribute("x-part-tag");
|
||||
if (mod_path && tag) {
|
||||
// Might not be present:
|
||||
var prefixes = elem.getAttribute("x-part-prefixes");
|
||||
|
||||
var info = document.createElement("div");
|
||||
info.className = "RPartExplain";
|
||||
|
||||
/* The "top" tag refers to a whole document: */
|
||||
var is_top = (tag == "\"top\"");
|
||||
info.appendChild(document.createTextNode("Link to this "
|
||||
+ (is_top ? "document" : "section")
|
||||
+ " with "));
|
||||
|
||||
/* Break `secref` into two lines if the module path and tag
|
||||
are long enough: */
|
||||
var is_long = (is_top ? false : ((mod_path.length
|
||||
+ tag.length
|
||||
+ (prefixes ? (16 + prefixes.length) : 0))
|
||||
> 60));
|
||||
|
||||
var line1 = document.createElement("div");
|
||||
var line1x = ((is_long && prefixes) ? document.createElement("div") : line1);
|
||||
var line2 = (is_long ? document.createElement("div") : line1);
|
||||
|
||||
function add(dest, str, cn) {
|
||||
var s = document.createElement("span");
|
||||
s.className = cn;
|
||||
s.style.whiteSpace = "nowrap";
|
||||
s.appendChild(document.createTextNode(str));
|
||||
dest.appendChild(s);
|
||||
}
|
||||
/* Construct a `secref` call with suitable syntax coloring: */
|
||||
add(line1, "\xA0@", "RktRdr");
|
||||
add(line1, (is_top ? "other-doc" : "secref"), "RktSym");
|
||||
add(line1, "[", "RktPn");
|
||||
if (!is_top)
|
||||
add(line1, tag, "RktVal");
|
||||
if (is_long) {
|
||||
/* indent additional lines: */
|
||||
if (prefixes)
|
||||
add(line1x, "\xA0\xA0\xA0\xA0\xA0\xA0\xA0\xA0", "RktPn");
|
||||
add(line2, "\xA0\xA0\xA0\xA0\xA0\xA0\xA0\xA0", "RktPn");
|
||||
}
|
||||
if (prefixes) {
|
||||
add(line1x, " #:tag-prefixes ", "RktPn");
|
||||
add(line1x, "'", "RktVal");
|
||||
add(line1x, prefixes, "RktVal");
|
||||
}
|
||||
if (!is_top)
|
||||
add(line2, " #:doc ", "RktPn");
|
||||
add(line2, "'", "RktVal");
|
||||
add(line2, mod_path, "RktVal");
|
||||
add(line2, "]", "RktPn");
|
||||
|
||||
info.appendChild(line1);
|
||||
if (is_long)
|
||||
info.appendChild(line1x);
|
||||
if (is_long)
|
||||
info.appendChild(line2);
|
||||
|
||||
info.style.display = "none";
|
||||
|
||||
/* Add the new element afterthe header: */
|
||||
var n = elem.nextSibling;
|
||||
if (n)
|
||||
elem.parentNode.insertBefore(info, n);
|
||||
else
|
||||
elem.parentNode.appendChild(info);
|
||||
|
||||
/* Clicking the header shows the explanation element: */
|
||||
elem.onclick = function () {
|
||||
if (info.style.display == "none")
|
||||
info.style.display = "block";
|
||||
else
|
||||
info.style.display = "none";
|
||||
}
|
||||
}
|
||||
}
|
||||
@ -1,743 +0,0 @@
|
||||
|
||||
/* See the beginning of "scribble.css".
|
||||
This file is used by the `scribble/manual` language, along with
|
||||
"manual-racket.css". */
|
||||
|
||||
@import url("manual-fonts.css");
|
||||
|
||||
* {
|
||||
margin: 0;
|
||||
padding: 0;
|
||||
}
|
||||
|
||||
@media all {html {font-size: 15px;}}
|
||||
@media all and (max-width:940px){html {font-size: 14px;}}
|
||||
@media all and (max-width:850px){html {font-size: 13px;}}
|
||||
@media all and (max-width:830px){html {font-size: 12px;}}
|
||||
@media all and (max-width:740px){html {font-size: 11px;}}
|
||||
|
||||
/* CSS seems backward: List all the classes for which we want a
|
||||
particular font, so that the font can be changed in one place. (It
|
||||
would be nicer to reference a font definition from all the places
|
||||
that we want it.)
|
||||
|
||||
As you read the rest of the file, remember to double-check here to
|
||||
see if any font is set. */
|
||||
|
||||
/* Monospace: */
|
||||
.maincolumn, .refpara, .refelem, .tocset, .stt, .hspace, .refparaleft, .refelemleft {
|
||||
font-family: 'Source Code Pro', monospace;
|
||||
white-space: inherit;
|
||||
font-size: 1rem;
|
||||
}
|
||||
|
||||
.stt {
|
||||
font-weight: 500;
|
||||
}
|
||||
|
||||
h2 .stt {
|
||||
font-size: 2.7rem;
|
||||
}
|
||||
|
||||
.toptoclink .stt {
|
||||
font-size: inherit;
|
||||
}
|
||||
.toclink .stt {
|
||||
font-size: 90%;
|
||||
}
|
||||
|
||||
.RpackageSpec .stt {
|
||||
font-weight: 300;
|
||||
font-family: 'Source Code Pro';
|
||||
font-size: 0.9rem;
|
||||
}
|
||||
|
||||
h3 .stt, h4 .stt, h5 .stt {
|
||||
color: #333;
|
||||
font-size: 1.65rem;
|
||||
font-weight: 400;
|
||||
}
|
||||
|
||||
|
||||
/* Serif: */
|
||||
.main, .refcontent, .tocview, .tocsub, .sroman, i {
|
||||
font-family: 'Charter', serif;
|
||||
font-size: 1.18rem;
|
||||
}
|
||||
|
||||
|
||||
/* Sans-serif: */
|
||||
.version, .versionNoNav, .ssansserif {
|
||||
font-family: 'Fira', sans-serif;
|
||||
}
|
||||
.ssansserif {
|
||||
font-family: 'Fira';
|
||||
font-weight: 500;
|
||||
font-size: 0.9em;
|
||||
}
|
||||
|
||||
.tocset .ssansserif {
|
||||
font-size: 100%;
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
|
||||
p, .SIntrapara {
|
||||
display: block;
|
||||
margin: 0 0 1em 0;
|
||||
line-height: 1.4;
|
||||
}
|
||||
|
||||
.compact {
|
||||
padding: 0 0 1em 0;
|
||||
}
|
||||
|
||||
li {
|
||||
list-style-position: outside;
|
||||
margin-left: 1.2em;
|
||||
}
|
||||
|
||||
h1, h2, h3, h4, h5, h6, h7, h8 {
|
||||
font-family: 'Fira';
|
||||
font-weight: 300;
|
||||
font-size: 1.6rem;
|
||||
color: #333;
|
||||
margin-top: inherit;
|
||||
margin-bottom: 1rem;
|
||||
line-height: 1.25;
|
||||
-moz-font-feature-settings: 'tnum=1';
|
||||
-moz-font-feature-settings: 'tnum' 1;
|
||||
-webkit-font-feature-settings: 'tnum' 1;
|
||||
-o-font-feature-settings: 'tnum' 1;
|
||||
-ms-font-feature-settings: 'tnum' 1;
|
||||
font-feature-settings: 'tnum' 1;
|
||||
|
||||
}
|
||||
|
||||
h3, h4, h5, h6, h7, h8 {
|
||||
border-top: 1px solid black;
|
||||
}
|
||||
|
||||
|
||||
|
||||
h2 { /* per-page main title */
|
||||
font-family: 'Miso';
|
||||
font-weight: bold;
|
||||
margin-top: 4rem;
|
||||
font-size: 3rem;
|
||||
line-height: 1.1;
|
||||
width: 90%;
|
||||
}
|
||||
|
||||
h3, h4, h5, h6, h7, h8 {
|
||||
margin-top: 2em;
|
||||
padding-top: 0.1em;
|
||||
margin-bottom: 0.75em;
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* Main */
|
||||
|
||||
body {
|
||||
color: black;
|
||||
background-color: white;
|
||||
}
|
||||
|
||||
.maincolumn {
|
||||
width: auto;
|
||||
margin-top: 4rem;
|
||||
margin-left: 17rem;
|
||||
margin-right: 2rem;
|
||||
margin-bottom: 10rem; /* to avoid fixed bottom nav bar */
|
||||
max-width: 700px;
|
||||
min-width: 370px; /* below this size, code samples don't fit */
|
||||
}
|
||||
|
||||
a {
|
||||
text-decoration: inherit;
|
||||
}
|
||||
|
||||
a, .toclink, .toptoclink, .tocviewlink, .tocviewselflink, .tocviewtoggle, .plainlink,
|
||||
.techinside, .techoutside:hover, .techinside:hover {
|
||||
color: #07A;
|
||||
}
|
||||
|
||||
a:hover {
|
||||
text-decoration: underline;
|
||||
}
|
||||
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* Navigation */
|
||||
|
||||
.navsettop, .navsetbottom {
|
||||
left: 0;
|
||||
width: 15rem;
|
||||
height: 6rem;
|
||||
font-family: 'Fira';
|
||||
font-size: 0.9rem;
|
||||
border-bottom: 0px solid hsl(216, 15%, 70%);
|
||||
background-color: inherit;
|
||||
padding: 0;
|
||||
}
|
||||
|
||||
.navsettop {
|
||||
position: absolute;
|
||||
top: 0;
|
||||
left: 0;
|
||||
margin-bottom: 0;
|
||||
border-bottom: 0;
|
||||
}
|
||||
|
||||
.navsettop a, .navsetbottom a {
|
||||
color: black;
|
||||
}
|
||||
|
||||
.navsettop a:hover, .navsetbottom a:hover {
|
||||
background: hsl(216, 78%, 95%);
|
||||
text-decoration: none;
|
||||
}
|
||||
|
||||
.navleft, .navright {
|
||||
position: static;
|
||||
float: none;
|
||||
margin: 0;
|
||||
white-space: normal;
|
||||
}
|
||||
|
||||
|
||||
.navleft a {
|
||||
display: inline-block;
|
||||
}
|
||||
|
||||
.navright a {
|
||||
display: inline-block;
|
||||
text-align: center;
|
||||
}
|
||||
|
||||
.navleft a, .navright a, .navright span {
|
||||
display: inline-block;
|
||||
padding: 0.5rem;
|
||||
min-width: 1rem;
|
||||
}
|
||||
|
||||
|
||||
.navright {
|
||||
height: 2rem;
|
||||
white-space: nowrap;
|
||||
}
|
||||
|
||||
|
||||
.navsetbottom {
|
||||
display: none;
|
||||
}
|
||||
|
||||
.nonavigation {
|
||||
color: #889;
|
||||
}
|
||||
|
||||
.searchform {
|
||||
display: block;
|
||||
margin: 0;
|
||||
padding: 0;
|
||||
border-bottom: 1px solid #eee;
|
||||
height: 4rem;
|
||||
}
|
||||
|
||||
.nosearchform {
|
||||
margin: 0;
|
||||
padding: 0;
|
||||
height: 4rem;
|
||||
}
|
||||
|
||||
.searchbox {
|
||||
font-size: 1rem;
|
||||
width: 12rem;
|
||||
margin: 1rem;
|
||||
padding: 0.25rem;
|
||||
vertical-align: middle;
|
||||
background-color: white;
|
||||
}
|
||||
|
||||
#search_box {
|
||||
font-size: 0.8rem;
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* Version */
|
||||
|
||||
.versionbox {
|
||||
position: absolute;
|
||||
float: none;
|
||||
top: 0.25rem;
|
||||
left: 17rem;
|
||||
z-index: 11000;
|
||||
height: 2em;
|
||||
font-size: 70%;
|
||||
font-weight: lighter;
|
||||
width: inherit;
|
||||
margin: 0;
|
||||
}
|
||||
.version, .versionNoNav {
|
||||
font-size: inherit;
|
||||
}
|
||||
.version:before, .versionNoNav:before {
|
||||
content: "v.";
|
||||
}
|
||||
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* Margin notes */
|
||||
|
||||
/* cancel scribble.css styles: */
|
||||
.refpara, .refelem {
|
||||
position: static;
|
||||
float: none;
|
||||
height: auto;
|
||||
width: auto;
|
||||
margin: 0;
|
||||
}
|
||||
|
||||
.refcolumn {
|
||||
position: static;
|
||||
display: block;
|
||||
width: auto;
|
||||
font-size: inherit;
|
||||
margin: 2rem;
|
||||
margin-left: 2rem;
|
||||
padding: 0.5em;
|
||||
padding-left: 0.75em;
|
||||
padding-right: 1em;
|
||||
background: hsl(60, 29%, 94%);
|
||||
border: 1px solid #ccb;
|
||||
border-left: 0.4rem solid #ccb;
|
||||
}
|
||||
|
||||
|
||||
/* slightly different handling for margin-note* on narrow screens */
|
||||
@media all and (max-width:1260px) {
|
||||
span.refcolumn {
|
||||
float: right;
|
||||
width: 50%;
|
||||
margin-left: 1rem;
|
||||
margin-bottom: 0.8rem;
|
||||
margin-top: 1.2rem;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
.refcontent, .refcontent p {
|
||||
line-height: 1.5;
|
||||
margin: 0;
|
||||
}
|
||||
|
||||
.refcontent p + p {
|
||||
margin-top: 1em;
|
||||
}
|
||||
|
||||
.refcontent a {
|
||||
font-weight: 400;
|
||||
}
|
||||
|
||||
.refpara, .refparaleft {
|
||||
top: -1em;
|
||||
}
|
||||
|
||||
|
||||
@media all and (max-width:600px) {
|
||||
.refcolumn {
|
||||
margin-left: 0;
|
||||
margin-right: 0;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
@media all and (min-width:1260px) {
|
||||
.refcolumn {
|
||||
position: absolute;
|
||||
left: 66rem; right: 3em;
|
||||
margin: 0;
|
||||
float: right;
|
||||
max-width: 18rem;
|
||||
}
|
||||
}
|
||||
|
||||
.refcontent {
|
||||
font-family: 'Fira';
|
||||
font-size: 1rem;
|
||||
line-height: 1.6;
|
||||
margin: 0 0 0 0;
|
||||
}
|
||||
|
||||
|
||||
.refparaleft, .refelemleft {
|
||||
position: relative;
|
||||
float: left;
|
||||
right: 2em;
|
||||
height: 0em;
|
||||
width: 13em;
|
||||
margin: 0em 0em 0em -13em;
|
||||
}
|
||||
|
||||
.refcolumnleft {
|
||||
background-color: hsl(60, 29%, 94%);
|
||||
display: block;
|
||||
position: relative;
|
||||
width: 13em;
|
||||
font-size: 85%;
|
||||
border: 0.5em solid hsl(60, 29%, 94%);
|
||||
margin: 0 0 0 0;
|
||||
}
|
||||
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* Table of contents, left margin */
|
||||
|
||||
.tocset {
|
||||
position: absolute;
|
||||
float: none;
|
||||
left: 0;
|
||||
top: 0rem;
|
||||
width: 14rem;
|
||||
padding: 7rem 0.5rem 0.5rem 0.5rem;
|
||||
background-color: hsl(216, 15%, 70%);
|
||||
margin: 0;
|
||||
|
||||
}
|
||||
|
||||
.tocset td {
|
||||
vertical-align: text-top;
|
||||
padding-bottom: 0.4rem;
|
||||
padding-left: 0.2rem;
|
||||
line-height: 1.1;
|
||||
font-family: 'Fira';
|
||||
-moz-font-feature-settings: 'tnum=1';
|
||||
-moz-font-feature-settings: 'tnum' 1;
|
||||
-webkit-font-feature-settings: 'tnum' 1;
|
||||
-o-font-feature-settings: 'tnum' 1;
|
||||
-ms-font-feature-settings: 'tnum' 1;
|
||||
font-feature-settings: 'tnum' 1;
|
||||
|
||||
}
|
||||
|
||||
.tocset td a {
|
||||
color: black;
|
||||
font-weight: 400;
|
||||
}
|
||||
|
||||
|
||||
.tocview {
|
||||
text-align: left;
|
||||
background-color: inherit;
|
||||
}
|
||||
|
||||
|
||||
.tocview td, .tocsub td {
|
||||
line-height: 1.3;
|
||||
}
|
||||
|
||||
|
||||
.tocview table, .tocsub table {
|
||||
width: 90%;
|
||||
}
|
||||
|
||||
.tocset td a.tocviewselflink {
|
||||
font-weight: lighter;
|
||||
font-size: 110%; /* monospaced styles below don't need to enlarge */
|
||||
color: white;
|
||||
}
|
||||
|
||||
.tocviewselflink {
|
||||
text-decoration: none;
|
||||
}
|
||||
|
||||
.tocsub {
|
||||
text-align: left;
|
||||
margin-top: 0.5em;
|
||||
background-color: inherit;
|
||||
}
|
||||
|
||||
.tocviewlist, .tocsublist {
|
||||
margin-left: 0.2em;
|
||||
margin-right: 0.2em;
|
||||
padding-top: 0.2em;
|
||||
padding-bottom: 0.2em;
|
||||
}
|
||||
.tocviewlist table {
|
||||
font-size: 82%;
|
||||
}
|
||||
|
||||
.tocviewlisttopspace {
|
||||
margin-bottom: 1em;
|
||||
}
|
||||
|
||||
.tocviewsublist, .tocviewsublistonly, .tocviewsublisttop, .tocviewsublistbottom {
|
||||
margin-left: 0.4em;
|
||||
border-left: 1px solid #99a;
|
||||
padding-left: 0.8em;
|
||||
}
|
||||
.tocviewsublist {
|
||||
margin-bottom: 1em;
|
||||
}
|
||||
.tocviewsublist table,
|
||||
.tocviewsublistonly table,
|
||||
.tocviewsublisttop table,
|
||||
.tocviewsublistbottom table,
|
||||
table.tocsublist {
|
||||
font-size: 1rem;
|
||||
}
|
||||
|
||||
.tocviewsublist td, .tocviewsublistbottom td, .tocviewsublisttop td, .tocsub td,
|
||||
.tocviewsublistonly td {
|
||||
font-size: 90%;
|
||||
}
|
||||
|
||||
|
||||
.tocviewtoggle {
|
||||
font-size: 75%; /* looks better, and avoids bounce when toggling sub-sections due to font alignments */
|
||||
}
|
||||
|
||||
.tocsublist td {
|
||||
padding-left: 0.5rem;
|
||||
padding-top: 0.25rem;
|
||||
text-indent: 0;
|
||||
}
|
||||
|
||||
.tocsublinknumber {
|
||||
font-size: 100%;
|
||||
}
|
||||
|
||||
.tocsublink {
|
||||
font-size: 82%;
|
||||
text-decoration: none;
|
||||
}
|
||||
|
||||
.tocsubseclink {
|
||||
font-size: 100%;
|
||||
text-decoration: none;
|
||||
}
|
||||
|
||||
.tocsubnonseclink {
|
||||
font-size: 82%;
|
||||
text-decoration: none;
|
||||
margin-left: 1rem;
|
||||
padding-left: 0;
|
||||
display: inline-block;
|
||||
}
|
||||
|
||||
/* the label "on this page" */
|
||||
.tocsubtitle {
|
||||
display: block;
|
||||
font-size: 62%;
|
||||
font-family: 'Fira';
|
||||
font-weight: bolder;
|
||||
font-style: normal;
|
||||
letter-spacing: 2px;
|
||||
text-transform: uppercase;
|
||||
margin: 0.5em;
|
||||
}
|
||||
|
||||
.toptoclink {
|
||||
font-weight: bold;
|
||||
font-size: 110%;
|
||||
margin-bottom: 0.5rem;
|
||||
margin-top: 1.5rem;
|
||||
display: inline-block;
|
||||
}
|
||||
|
||||
.toclink {
|
||||
font-size: inherit;
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* Some inline styles */
|
||||
|
||||
.indexlink {
|
||||
text-decoration: none;
|
||||
}
|
||||
|
||||
pre {
|
||||
margin-left: 2em;
|
||||
}
|
||||
|
||||
blockquote {
|
||||
margin-left: 2em;
|
||||
margin-right: 2em;
|
||||
margin-bottom: 1em;
|
||||
}
|
||||
|
||||
.SCodeFlow {
|
||||
border-left: 1px dotted black;
|
||||
padding-left: 1em;
|
||||
padding-right: 1em;
|
||||
margin-top: 1em;
|
||||
margin-bottom: 1em;
|
||||
margin-left: 0em;
|
||||
margin-right: 2em;
|
||||
white-space: nowrap;
|
||||
line-height: 1.5;
|
||||
}
|
||||
|
||||
.SCodeFlow img {
|
||||
margin-top: 0.5em;
|
||||
margin-bottom: 0.5em;
|
||||
}
|
||||
|
||||
.boxed {
|
||||
margin: 0;
|
||||
margin-top: 2em;
|
||||
padding: 0.25em;
|
||||
padding-bottom: 0.5em;
|
||||
background: #f3f3f3;
|
||||
box-sizing:border-box;
|
||||
border-top: 1px solid #99b;
|
||||
background: hsl(216, 78%, 95%);
|
||||
background: -moz-linear-gradient(to bottom left, hsl(0, 0%, 99%) 0%, hsl(216, 78%, 95%) 100%);
|
||||
background: -webkit-linear-gradient(to bottom left, hsl(0, 0%, 99%) 0%, hsl(216, 78%, 95%) 100%);
|
||||
background: -o-linear-gradient(to bottom left, hsl(0, 0%, 99%) 0%, hsl(216, 78%, 95%) 100%);
|
||||
background: -ms-linear-gradient(to bottom left, hsl(0, 0%, 99%) 0%, hsl(216, 78%, 95%) 100%);
|
||||
background: linear-gradient(to bottom left, hsl(0, 0%, 99%) 0%, hsl(216, 78%, 95%) 100%);
|
||||
}
|
||||
|
||||
blockquote > blockquote.SVInsetFlow {
|
||||
/* resolves issue in e.g. /reference/notation.html */
|
||||
margin-top: 0em;
|
||||
}
|
||||
|
||||
.leftindent .SVInsetFlow { /* see e.g. section 4.5 of Racket Guide */
|
||||
margin-top: 1em;
|
||||
margin-bottom: 1em;
|
||||
}
|
||||
|
||||
.SVInsetFlow a, .SCodeFlow a {
|
||||
color: #07A;
|
||||
font-weight: 500;
|
||||
}
|
||||
|
||||
.SubFlow {
|
||||
display: block;
|
||||
margin: 0em;
|
||||
}
|
||||
|
||||
.boxed {
|
||||
width: 100%;
|
||||
background-color: inherit;
|
||||
}
|
||||
|
||||
.techoutside { text-decoration: none; }
|
||||
|
||||
.SAuthorListBox {
|
||||
position: static;
|
||||
float: none;
|
||||
font-family: 'Fira';
|
||||
font-weight: 300;
|
||||
font-size: 110%;
|
||||
margin-top: 1rem;
|
||||
margin-bottom: 3rem;
|
||||
width: 30rem;
|
||||
height: auto;
|
||||
}
|
||||
|
||||
.author > a { /* email links within author block */
|
||||
font-weight: inherit;
|
||||
color: inherit;
|
||||
}
|
||||
|
||||
.SAuthorList {
|
||||
font-size: 82%;
|
||||
}
|
||||
.SAuthorList:before {
|
||||
content: "by ";
|
||||
}
|
||||
.author {
|
||||
display: inline;
|
||||
white-space: nowrap;
|
||||
}
|
||||
|
||||
/* phone + tablet styles */
|
||||
|
||||
@media all and (max-width:720px){
|
||||
|
||||
|
||||
@media all and (max-width:720px){
|
||||
|
||||
@media all {html {font-size: 15px;}}
|
||||
@media all and (max-width:700px){html {font-size: 14px;}}
|
||||
@media all and (max-width:630px){html {font-size: 13px;}}
|
||||
@media all and (max-width:610px){html {font-size: 12px;}}
|
||||
@media all and (max-width:550px){html {font-size: 11px;}}
|
||||
@media all and (max-width:520px){html {font-size: 10px;}}
|
||||
|
||||
.navsettop, .navsetbottom {
|
||||
display: block;
|
||||
position: absolute;
|
||||
width: 100%;
|
||||
height: 4rem;
|
||||
border: 0;
|
||||
background-color: hsl(216, 15%, 70%);
|
||||
}
|
||||
|
||||
.searchform {
|
||||
display: inline;
|
||||
border: 0;
|
||||
}
|
||||
|
||||
.navright {
|
||||
position: absolute;
|
||||
right: 1.5rem;
|
||||
margin-top: 1rem;
|
||||
border: 0px solid red;
|
||||
}
|
||||
|
||||
.navsetbottom {
|
||||
display: block;
|
||||
margin-top: 8rem;
|
||||
}
|
||||
|
||||
.tocset {
|
||||
display: none;
|
||||
}
|
||||
|
||||
.tocset table, .tocset tbody, .tocset tr, .tocset td {
|
||||
display: inline;
|
||||
}
|
||||
|
||||
.tocview {
|
||||
display: none;
|
||||
}
|
||||
|
||||
.tocsub .tocsubtitle {
|
||||
display: none;
|
||||
}
|
||||
|
||||
.versionbox {
|
||||
top: 4.5rem;
|
||||
left: 1rem; /* same distance as main-column */
|
||||
z-index: 11000;
|
||||
height: 2em;
|
||||
font-size: 70%;
|
||||
font-weight: lighter;
|
||||
}
|
||||
|
||||
|
||||
.maincolumn {
|
||||
margin-left: 1em;
|
||||
margin-top: 7rem;
|
||||
margin-bottom: 0rem;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
/* print styles : hide the navigation elements */
|
||||
@media print {
|
||||
.tocset,
|
||||
.navsettop,
|
||||
.navsetbottom { display: none; }
|
||||
.maincolumn {
|
||||
width: auto;
|
||||
margin-right: 13em;
|
||||
margin-left: 0;
|
||||
}
|
||||
}
|
||||
File diff suppressed because one or more lines are too long
@ -1,249 +0,0 @@
|
||||
|
||||
/* See the beginning of "scribble.css". */
|
||||
|
||||
/* Monospace: */
|
||||
.RktIn, .RktRdr, .RktPn, .RktMeta,
|
||||
.RktMod, .RktKw, .RktVar, .RktSym,
|
||||
.RktRes, .RktOut, .RktCmt, .RktVal,
|
||||
.RktBlk {
|
||||
font-family: monospace;
|
||||
white-space: inherit;
|
||||
}
|
||||
|
||||
/* Serif: */
|
||||
.inheritedlbl {
|
||||
font-family: serif;
|
||||
}
|
||||
|
||||
/* Sans-serif: */
|
||||
.RBackgroundLabelInner {
|
||||
font-family: sans-serif;
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* Inherited methods, left margin */
|
||||
|
||||
.inherited {
|
||||
width: 100%;
|
||||
margin-top: 0.5em;
|
||||
text-align: left;
|
||||
background-color: #ECF5F5;
|
||||
}
|
||||
|
||||
.inherited td {
|
||||
font-size: 82%;
|
||||
padding-left: 1em;
|
||||
text-indent: -0.8em;
|
||||
padding-right: 0.2em;
|
||||
}
|
||||
|
||||
.inheritedlbl {
|
||||
font-style: italic;
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* Racket text styles */
|
||||
|
||||
.RktIn {
|
||||
color: #cc6633;
|
||||
background-color: #eeeeee;
|
||||
}
|
||||
|
||||
.RktInBG {
|
||||
background-color: #eeeeee;
|
||||
}
|
||||
|
||||
.RktRdr {
|
||||
}
|
||||
|
||||
.RktPn {
|
||||
color: #843c24;
|
||||
}
|
||||
|
||||
.RktMeta {
|
||||
color: black;
|
||||
}
|
||||
|
||||
.RktMod {
|
||||
color: black;
|
||||
}
|
||||
|
||||
.RktOpt {
|
||||
color: black;
|
||||
}
|
||||
|
||||
.RktKw {
|
||||
color: black;
|
||||
}
|
||||
|
||||
.RktErr {
|
||||
color: red;
|
||||
font-style: italic;
|
||||
}
|
||||
|
||||
.RktVar {
|
||||
color: #262680;
|
||||
font-style: italic;
|
||||
}
|
||||
|
||||
.RktSym {
|
||||
color: #262680;
|
||||
}
|
||||
|
||||
.RktSymDef { /* used with RktSym at def site */
|
||||
}
|
||||
|
||||
.RktValLink {
|
||||
text-decoration: none;
|
||||
color: blue;
|
||||
}
|
||||
|
||||
.RktValDef { /* used with RktValLink at def site */
|
||||
}
|
||||
|
||||
.RktModLink {
|
||||
text-decoration: none;
|
||||
color: blue;
|
||||
}
|
||||
|
||||
.RktStxLink {
|
||||
text-decoration: none;
|
||||
color: black;
|
||||
}
|
||||
|
||||
.RktStxDef { /* used with RktStxLink at def site */
|
||||
}
|
||||
|
||||
.RktRes {
|
||||
color: #0000af;
|
||||
}
|
||||
|
||||
.RktOut {
|
||||
color: #960096;
|
||||
}
|
||||
|
||||
.RktCmt {
|
||||
color: #c2741f;
|
||||
}
|
||||
|
||||
.RktVal {
|
||||
color: #228b22;
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* Some inline styles */
|
||||
|
||||
.together {
|
||||
width: 100%;
|
||||
}
|
||||
|
||||
.prototype, .argcontract, .RBoxed {
|
||||
white-space: nowrap;
|
||||
}
|
||||
|
||||
.prototype td {
|
||||
vertical-align: text-top;
|
||||
}
|
||||
|
||||
.RktBlk {
|
||||
white-space: inherit;
|
||||
text-align: left;
|
||||
}
|
||||
|
||||
.RktBlk tr {
|
||||
white-space: inherit;
|
||||
}
|
||||
|
||||
.RktBlk td {
|
||||
vertical-align: baseline;
|
||||
white-space: inherit;
|
||||
}
|
||||
|
||||
.argcontract td {
|
||||
vertical-align: text-top;
|
||||
}
|
||||
|
||||
.highlighted {
|
||||
background-color: #ddddff;
|
||||
}
|
||||
|
||||
.defmodule {
|
||||
width: 100%;
|
||||
background-color: #F5F5DC;
|
||||
}
|
||||
|
||||
.specgrammar {
|
||||
float: right;
|
||||
}
|
||||
|
||||
.RBibliography td {
|
||||
vertical-align: text-top;
|
||||
}
|
||||
|
||||
.leftindent {
|
||||
margin-left: 1em;
|
||||
margin-right: 0em;
|
||||
}
|
||||
|
||||
.insetpara {
|
||||
margin-left: 1em;
|
||||
margin-right: 1em;
|
||||
}
|
||||
|
||||
.Rfilebox {
|
||||
}
|
||||
|
||||
.Rfiletitle {
|
||||
text-align: right;
|
||||
margin: 0em 0em 0em 0em;
|
||||
}
|
||||
|
||||
.Rfilename {
|
||||
border-top: 1px solid #6C8585;
|
||||
border-right: 1px solid #6C8585;
|
||||
padding-left: 0.5em;
|
||||
padding-right: 0.5em;
|
||||
background-color: #ECF5F5;
|
||||
}
|
||||
|
||||
.Rfilecontent {
|
||||
margin: 0em 0em 0em 0em;
|
||||
}
|
||||
|
||||
.RpackageSpec {
|
||||
padding-right: 0.5em;
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* For background labels */
|
||||
|
||||
.RBackgroundLabel {
|
||||
float: right;
|
||||
width: 0px;
|
||||
height: 0px;
|
||||
}
|
||||
|
||||
.RBackgroundLabelInner {
|
||||
position: relative;
|
||||
width: 25em;
|
||||
left: -25.5em;
|
||||
top: 0px;
|
||||
text-align: right;
|
||||
color: white;
|
||||
z-index: 0;
|
||||
font-weight: bold;
|
||||
}
|
||||
|
||||
.RForeground {
|
||||
position: relative;
|
||||
left: 0px;
|
||||
top: 0px;
|
||||
z-index: 1;
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* History */
|
||||
|
||||
.SHistory {
|
||||
font-size: 82%;
|
||||
}
|
||||
@ -1,170 +0,0 @@
|
||||
// Common functionality for PLT documentation pages
|
||||
|
||||
// Page Parameters ------------------------------------------------------------
|
||||
|
||||
var page_query_string = location.search.substring(1);
|
||||
|
||||
var page_args =
|
||||
((function(){
|
||||
if (!page_query_string) return [];
|
||||
var args = page_query_string.split(/[&;]/);
|
||||
for (var i=0; i<args.length; i++) {
|
||||
var a = args[i];
|
||||
var p = a.indexOf('=');
|
||||
if (p >= 0) args[i] = [a.substring(0,p), a.substring(p+1)];
|
||||
else args[i] = [a, false];
|
||||
}
|
||||
return args;
|
||||
})());
|
||||
|
||||
function GetPageArg(key, def) {
|
||||
for (var i=0; i<page_args.length; i++)
|
||||
if (page_args[i][0] == key) return decodeURIComponent(page_args[i][1]);
|
||||
return def;
|
||||
}
|
||||
|
||||
function MergePageArgsIntoLink(a) {
|
||||
if (page_args.length == 0 ||
|
||||
(!a.attributes["data-pltdoc"]) || (a.attributes["data-pltdoc"].value == ""))
|
||||
return;
|
||||
a.href = MergePageArgsIntoUrl(a.href);
|
||||
}
|
||||
|
||||
function MergePageArgsIntoUrl(href) {
|
||||
var mtch = href.match(/^([^?#]*)(?:\?([^#]*))?(#.*)?$/);
|
||||
if (mtch == undefined) { // I think this never happens
|
||||
return "?" + page_query_string;
|
||||
}
|
||||
if (!mtch[2]) {
|
||||
return mtch[1] + "?" + page_query_string + (mtch[3] || "");
|
||||
}
|
||||
// need to merge here, precedence to arguments that exist in `a'
|
||||
var i, j;
|
||||
var prefix = mtch[1], str = mtch[2] || "", suffix = mtch[3] || "";
|
||||
var args = str.split(/[&;]/);
|
||||
for (i=0; i<args.length; i++) {
|
||||
j = args[i].indexOf('=');
|
||||
if (j) args[i] = args[i].substring(0,j);
|
||||
}
|
||||
var additions = "";
|
||||
for (i=0; i<page_args.length; i++) {
|
||||
var exists = false;
|
||||
for (j=0; j<args.length; j++)
|
||||
if (args[j] == page_args[i][0]) { exists = true; break; }
|
||||
if (!exists) str += "&" + page_args[i][0] + "=" + page_args[i][1];
|
||||
}
|
||||
return prefix + "?" + str + suffix;
|
||||
}
|
||||
|
||||
// Cookies --------------------------------------------------------------------
|
||||
|
||||
// Actually, try localStorage (a la HTML 5), first.
|
||||
|
||||
function GetCookie(key, def) {
|
||||
try {
|
||||
var v = localStorage[key];
|
||||
if (!v) v = def;
|
||||
return v;
|
||||
} catch (e) {
|
||||
var i, cookiestrs;
|
||||
try {
|
||||
if (document.cookie.length <= 0) return def;
|
||||
cookiestrs = document.cookie.split(/; */);
|
||||
} catch (e) { return def; }
|
||||
for (i = 0; i < cookiestrs.length; i++) {
|
||||
var cur = cookiestrs[i];
|
||||
var eql = cur.indexOf('=');
|
||||
if (eql >= 0 && cur.substring(0,eql) == key)
|
||||
return unescape(cur.substring(eql+1));
|
||||
}
|
||||
return def;
|
||||
}
|
||||
}
|
||||
|
||||
function SetCookie(key, val) {
|
||||
try {
|
||||
localStorage[key] = val;
|
||||
} catch(e) {
|
||||
var d = new Date();
|
||||
d.setTime(d.getTime()+(365*24*60*60*1000));
|
||||
try {
|
||||
document.cookie =
|
||||
key + "=" + escape(val) + "; expires="+ d.toGMTString() + "; path=/";
|
||||
} catch (e) {}
|
||||
}
|
||||
}
|
||||
|
||||
// note that this always stores a directory name, ending with a "/"
|
||||
function SetPLTRoot(ver, relative) {
|
||||
var root = location.protocol + "//" + location.host
|
||||
+ NormalizePath(location.pathname.replace(/[^\/]*$/, relative));
|
||||
SetCookie("PLT_Root."+ver, root);
|
||||
}
|
||||
|
||||
// adding index.html works because of the above
|
||||
function GotoPLTRoot(ver, relative) {
|
||||
var u = GetCookie("PLT_Root."+ver, null);
|
||||
if (u == null) return true; // no cookie: use plain up link
|
||||
// the relative path is optional, default goes to the toplevel start page
|
||||
if (!relative) relative = "index.html";
|
||||
location = u + relative;
|
||||
return false;
|
||||
}
|
||||
|
||||
// Utilities ------------------------------------------------------------------
|
||||
|
||||
var normalize_rxs = [/\/\/+/g, /\/\.(\/|$)/, /\/[^\/]*\/\.\.(\/|$)/];
|
||||
function NormalizePath(path) {
|
||||
var tmp, i;
|
||||
for (i = 0; i < normalize_rxs.length; i++)
|
||||
while ((tmp = path.replace(normalize_rxs[i], "/")) != path) path = tmp;
|
||||
return path;
|
||||
}
|
||||
|
||||
// `noscript' is problematic in some browsers (always renders as a
|
||||
// block), use this hack instead (does not always work!)
|
||||
// document.write("<style>mynoscript { display:none; }</style>");
|
||||
|
||||
// Interactions ---------------------------------------------------------------
|
||||
|
||||
function DoSearchKey(event, field, ver, top_path) {
|
||||
var val = field.value;
|
||||
if (event && event.keyCode == 13) {
|
||||
var u = GetCookie("PLT_Root."+ver, null);
|
||||
if (u == null) u = top_path; // default: go to the top path
|
||||
u += "search/index.html?q=" + encodeURIComponent(val);
|
||||
u = MergePageArgsIntoUrl(u);
|
||||
location = u;
|
||||
return false;
|
||||
}
|
||||
return true;
|
||||
}
|
||||
|
||||
function TocviewToggle(glyph, id) {
|
||||
var s = document.getElementById(id).style;
|
||||
var expand = s.display == "none";
|
||||
s.display = expand ? "block" : "none";
|
||||
glyph.innerHTML = expand ? "▼" : "►";
|
||||
}
|
||||
|
||||
// Page Init ------------------------------------------------------------------
|
||||
|
||||
// Note: could make a function that inspects and uses window.onload to chain to
|
||||
// a previous one, but this file needs to be required first anyway, since it
|
||||
// contains utilities for all other files.
|
||||
var on_load_funcs = [];
|
||||
function AddOnLoad(fun) { on_load_funcs.push(fun); }
|
||||
window.onload = function() {
|
||||
for (var i=0; i<on_load_funcs.length; i++) on_load_funcs[i]();
|
||||
};
|
||||
|
||||
AddOnLoad(function(){
|
||||
var links = document.getElementsByTagName("a");
|
||||
for (var i=0; i<links.length; i++) MergePageArgsIntoLink(links[i]);
|
||||
var label = GetPageArg("ctxtname",false);
|
||||
if (!label) return;
|
||||
var indicator = document.getElementById("contextindicator");
|
||||
if (!indicator) return;
|
||||
indicator.innerHTML = label;
|
||||
indicator.style.display = "block";
|
||||
});
|
||||
@ -1,484 +0,0 @@
|
||||
|
||||
/* This file is used by default by all Scribble documents.
|
||||
See also "manual.css", which is added by default by the
|
||||
`scribble/manual` language. */
|
||||
|
||||
/* CSS seems backward: List all the classes for which we want a
|
||||
particular font, so that the font can be changed in one place. (It
|
||||
would be nicer to reference a font definition from all the places
|
||||
that we want it.)
|
||||
|
||||
As you read the rest of the file, remember to double-check here to
|
||||
see if any font is set. */
|
||||
|
||||
/* Monospace: */
|
||||
.maincolumn, .refpara, .refelem, .tocset, .stt, .hspace, .refparaleft, .refelemleft {
|
||||
font-family: monospace;
|
||||
}
|
||||
|
||||
/* Serif: */
|
||||
.main, .refcontent, .tocview, .tocsub, .sroman, i {
|
||||
font-family: serif;
|
||||
}
|
||||
|
||||
/* Sans-serif: */
|
||||
.version, .versionNoNav, .ssansserif {
|
||||
font-family: sans-serif;
|
||||
}
|
||||
.ssansserif {
|
||||
font-size: 80%;
|
||||
font-weight: bold;
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
|
||||
p, .SIntrapara {
|
||||
display: block;
|
||||
margin: 1em 0;
|
||||
}
|
||||
|
||||
h2 { /* per-page main title */
|
||||
margin-top: 0;
|
||||
}
|
||||
|
||||
h3, h4, h5, h6, h7, h8 {
|
||||
margin-top: 1.75em;
|
||||
margin-bottom: 0.5em;
|
||||
}
|
||||
|
||||
.SSubSubSubSection {
|
||||
font-weight: bold;
|
||||
font-size: 0.83em; /* should match h5; from HTML 4 reference */
|
||||
}
|
||||
|
||||
/* Needed for browsers like Opera, and eventually for HTML 4 conformance.
|
||||
This means that multiple paragraphs in a table element do not have a space
|
||||
between them. */
|
||||
table p {
|
||||
margin-top: 0;
|
||||
margin-bottom: 0;
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* Main */
|
||||
|
||||
body {
|
||||
color: black;
|
||||
background-color: #ffffff;
|
||||
}
|
||||
|
||||
table td {
|
||||
padding-left: 0;
|
||||
padding-right: 0;
|
||||
}
|
||||
|
||||
.maincolumn {
|
||||
width: 43em;
|
||||
margin-right: -40em;
|
||||
margin-left: 15em;
|
||||
}
|
||||
|
||||
.main {
|
||||
text-align: left;
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* Navigation */
|
||||
|
||||
.navsettop, .navsetbottom {
|
||||
background-color: #f0f0e0;
|
||||
padding: 0.25em 0 0.25em 0;
|
||||
}
|
||||
|
||||
.navsettop {
|
||||
margin-bottom: 1.5em;
|
||||
border-bottom: 2px solid #e0e0c0;
|
||||
}
|
||||
|
||||
.navsetbottom {
|
||||
margin-top: 2em;
|
||||
border-top: 2px solid #e0e0c0;
|
||||
}
|
||||
|
||||
.navleft {
|
||||
margin-left: 1ex;
|
||||
position: relative;
|
||||
float: left;
|
||||
white-space: nowrap;
|
||||
}
|
||||
.navright {
|
||||
margin-right: 1ex;
|
||||
position: relative;
|
||||
float: right;
|
||||
white-space: nowrap;
|
||||
}
|
||||
.nonavigation {
|
||||
color: #e0e0e0;
|
||||
}
|
||||
|
||||
.searchform {
|
||||
display: inline;
|
||||
margin: 0;
|
||||
padding: 0;
|
||||
}
|
||||
|
||||
.nosearchform {
|
||||
display: none;
|
||||
}
|
||||
|
||||
.searchbox {
|
||||
width: 16em;
|
||||
margin: 0px;
|
||||
padding: 0px;
|
||||
background-color: #eee;
|
||||
border: 1px solid #ddd;
|
||||
text-align: center;
|
||||
vertical-align: middle;
|
||||
}
|
||||
|
||||
#contextindicator {
|
||||
position: fixed;
|
||||
background-color: #c6f;
|
||||
color: #000;
|
||||
font-family: monospace;
|
||||
font-weight: bold;
|
||||
padding: 2px 10px;
|
||||
display: none;
|
||||
right: 0;
|
||||
bottom: 0;
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* Version */
|
||||
|
||||
.versionbox {
|
||||
position: relative;
|
||||
float: right;
|
||||
left: 2em;
|
||||
height: 0em;
|
||||
width: 13em;
|
||||
margin: 0em -13em 0em 0em;
|
||||
}
|
||||
.version {
|
||||
font-size: small;
|
||||
}
|
||||
.versionNoNav {
|
||||
font-size: xx-small; /* avoid overlap with author */
|
||||
}
|
||||
|
||||
.version:before, .versionNoNav:before {
|
||||
content: "Version ";
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* Margin notes */
|
||||
|
||||
.refpara, .refelem {
|
||||
position: relative;
|
||||
float: right;
|
||||
left: 2em;
|
||||
height: 0em;
|
||||
width: 13em;
|
||||
margin: 0em -13em 0em 0em;
|
||||
}
|
||||
|
||||
.refpara, .refparaleft {
|
||||
top: -1em;
|
||||
}
|
||||
|
||||
.refcolumn {
|
||||
background-color: #F5F5DC;
|
||||
display: block;
|
||||
position: relative;
|
||||
width: 13em;
|
||||
font-size: 85%;
|
||||
border: 0.5em solid #F5F5DC;
|
||||
margin: 0 0 0 0;
|
||||
}
|
||||
|
||||
.refcontent {
|
||||
margin: 0 0 0 0;
|
||||
}
|
||||
|
||||
.refcontent p {
|
||||
margin-top: 0;
|
||||
margin-bottom: 0;
|
||||
}
|
||||
|
||||
.refparaleft, .refelemleft {
|
||||
position: relative;
|
||||
float: left;
|
||||
right: 2em;
|
||||
height: 0em;
|
||||
width: 13em;
|
||||
margin: 0em 0em 0em -13em;
|
||||
}
|
||||
|
||||
.refcolumnleft {
|
||||
background-color: #F5F5DC;
|
||||
display: block;
|
||||
position: relative;
|
||||
width: 13em;
|
||||
font-size: 85%;
|
||||
border: 0.5em solid #F5F5DC;
|
||||
margin: 0 0 0 0;
|
||||
}
|
||||
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* Table of contents, inline */
|
||||
|
||||
.toclink {
|
||||
text-decoration: none;
|
||||
color: blue;
|
||||
font-size: 85%;
|
||||
}
|
||||
|
||||
.toptoclink {
|
||||
text-decoration: none;
|
||||
color: blue;
|
||||
font-weight: bold;
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* Table of contents, left margin */
|
||||
|
||||
.tocset {
|
||||
position: relative;
|
||||
float: left;
|
||||
width: 12.5em;
|
||||
margin-right: 2em;
|
||||
}
|
||||
.tocset td {
|
||||
vertical-align: text-top;
|
||||
}
|
||||
|
||||
.tocview {
|
||||
text-align: left;
|
||||
background-color: #f0f0e0;
|
||||
}
|
||||
|
||||
.tocsub {
|
||||
text-align: left;
|
||||
margin-top: 0.5em;
|
||||
background-color: #f0f0e0;
|
||||
}
|
||||
|
||||
.tocviewlist, .tocsublist {
|
||||
margin-left: 0.2em;
|
||||
margin-right: 0.2em;
|
||||
padding-top: 0.2em;
|
||||
padding-bottom: 0.2em;
|
||||
}
|
||||
.tocviewlist table {
|
||||
font-size: 82%;
|
||||
}
|
||||
|
||||
.tocviewlisttopspace {
|
||||
margin-bottom: 1em;
|
||||
}
|
||||
|
||||
.tocviewsublist, .tocviewsublistonly, .tocviewsublisttop, .tocviewsublistbottom {
|
||||
margin-left: 0.4em;
|
||||
border-left: 1px solid #bbf;
|
||||
padding-left: 0.8em;
|
||||
}
|
||||
.tocviewsublist {
|
||||
margin-bottom: 1em;
|
||||
}
|
||||
.tocviewsublist table,
|
||||
.tocviewsublistonly table,
|
||||
.tocviewsublisttop table,
|
||||
.tocviewsublistbottom table {
|
||||
font-size: 75%;
|
||||
}
|
||||
|
||||
.tocviewtitle * {
|
||||
font-weight: bold;
|
||||
}
|
||||
|
||||
.tocviewlink {
|
||||
text-decoration: none;
|
||||
color: blue;
|
||||
}
|
||||
|
||||
.tocviewselflink {
|
||||
text-decoration: underline;
|
||||
color: blue;
|
||||
}
|
||||
|
||||
.tocviewtoggle {
|
||||
text-decoration: none;
|
||||
color: blue;
|
||||
font-size: 75%; /* looks better, and avoids bounce when toggling sub-sections due to font alignments */
|
||||
}
|
||||
|
||||
.tocsublist td {
|
||||
padding-left: 1em;
|
||||
text-indent: -1em;
|
||||
}
|
||||
|
||||
.tocsublinknumber {
|
||||
font-size: 82%;
|
||||
}
|
||||
|
||||
.tocsublink {
|
||||
font-size: 82%;
|
||||
text-decoration: none;
|
||||
}
|
||||
|
||||
.tocsubseclink {
|
||||
font-size: 82%;
|
||||
text-decoration: none;
|
||||
}
|
||||
|
||||
.tocsubnonseclink {
|
||||
font-size: 82%;
|
||||
text-decoration: none;
|
||||
padding-left: 0.5em;
|
||||
}
|
||||
|
||||
.tocsubtitle {
|
||||
font-size: 82%;
|
||||
font-style: italic;
|
||||
margin: 0.2em;
|
||||
}
|
||||
|
||||
/* ---------------------------------------- */
|
||||
/* Some inline styles */
|
||||
|
||||
.indexlink {
|
||||
text-decoration: none;
|
||||
}
|
||||
|
||||
.nobreak {
|
||||
white-space: nowrap;
|
||||
}
|
||||
|
||||
pre { margin-left: 2em; }
|
||||
blockquote { margin-left: 2em; }
|
||||
|
||||
ol { list-style-type: decimal; }
|
||||
ol ol { list-style-type: lower-alpha; }
|
||||
ol ol ol { list-style-type: lower-roman; }
|
||||
ol ol ol ol { list-style-type: upper-alpha; }
|
||||
|
||||
.SCodeFlow {
|
||||
display: block;
|
||||
margin-left: 1em;
|
||||
margin-bottom: 0em;
|
||||
margin-right: 1em;
|
||||
margin-top: 0em;
|
||||
white-space: nowrap;
|
||||
}
|
||||
|
||||
.SVInsetFlow {
|
||||
display: block;
|
||||
margin-left: 0em;
|
||||
margin-bottom: 0em;
|
||||
margin-right: 0em;
|
||||
margin-top: 0em;
|
||||
}
|
||||
|
||||
.SubFlow {
|
||||
display: block;
|
||||
margin: 0em;
|
||||
}
|
||||
|
||||
.boxed {
|
||||
width: 100%;
|
||||
background-color: #E8E8FF;
|
||||
}
|
||||
|
||||
.hspace {
|
||||
}
|
||||
|
||||
.slant {
|
||||
font-style: oblique;
|
||||
}
|
||||
|
||||
.badlink {
|
||||
text-decoration: underline;
|
||||
color: red;
|
||||
}
|
||||
|
||||
.plainlink {
|
||||
text-decoration: none;
|
||||
color: blue;
|
||||
}
|
||||
|
||||
.techoutside { text-decoration: underline; color: #b0b0b0; }
|
||||
.techoutside:hover { text-decoration: underline; color: blue; }
|
||||
|
||||
/* .techinside:hover doesn't work with FF, .techinside:hover>
|
||||
.techinside doesn't work with IE, so use both (and IE doesn't
|
||||
work with inherit in the second one, so use blue directly) */
|
||||
.techinside { color: black; }
|
||||
.techinside:hover { color: blue; }
|
||||
.techoutside:hover>.techinside { color: inherit; }
|
||||
|
||||
.SCentered {
|
||||
text-align: center;
|
||||
}
|
||||
|
||||
.imageleft {
|
||||
float: left;
|
||||
margin-right: 0.3em;
|
||||
}
|
||||
|
||||
.Smaller {
|
||||
font-size: 82%;
|
||||
}
|
||||
|
||||
.Larger {
|
||||
font-size: 122%;
|
||||
}
|
||||
|
||||
/* A hack, inserted to break some Scheme ids: */
|
||||
.mywbr {
|
||||
display: inline-block;
|
||||
height: 0;
|
||||
width: 0;
|
||||
font-size: 1px;
|
||||
}
|
||||
|
||||
.compact li p {
|
||||
margin: 0em;
|
||||
padding: 0em;
|
||||
}
|
||||
|
||||
.noborder img {
|
||||
border: 0;
|
||||
}
|
||||
|
||||
.SAuthorListBox {
|
||||
position: relative;
|
||||
float: right;
|
||||
left: 2em;
|
||||
top: -2.5em;
|
||||
height: 0em;
|
||||
width: 13em;
|
||||
margin: 0em -13em 0em 0em;
|
||||
}
|
||||
.SAuthorList {
|
||||
font-size: 82%;
|
||||
}
|
||||
.SAuthorList:before {
|
||||
content: "by ";
|
||||
}
|
||||
.author {
|
||||
display: inline;
|
||||
white-space: nowrap;
|
||||
}
|
||||
|
||||
/* print styles : hide the navigation elements */
|
||||
@media print {
|
||||
.tocset,
|
||||
.navsettop,
|
||||
.navsetbottom { display: none; }
|
||||
.maincolumn {
|
||||
width: auto;
|
||||
margin-right: 13em;
|
||||
margin-left: 0;
|
||||
}
|
||||
}
|
||||
@ -1,17 +0,0 @@
|
||||
#lang racket/base
|
||||
(require "typeset.rkt" "samples.rkt" "render.rkt" "world.rkt" racket/class "logger.rkt")
|
||||
|
||||
(module+ main
|
||||
(define line-limit (with-handlers ([exn:fail? (λ(exn) #f)])
|
||||
(string->number (vector-ref (current-command-line-arguments) 0))))
|
||||
(activate-logger quad-logger)
|
||||
(parameterize ([world:quality-default world:max-quality]
|
||||
[world:paper-width-default 412]
|
||||
[world:paper-height-default 600])
|
||||
(define path "texts/segfault.txt")
|
||||
(displayln "Making text sample")
|
||||
(define text-sample (time (make-sample path line-limit)))
|
||||
(displayln "Typsetting sample")
|
||||
(define typeset-sample (time (typeset text-sample)))
|
||||
(displayln "Rendering sample to PDF")
|
||||
(time (send (new pdf-renderer%) render-to-file typeset-sample "texts/segfault.pdf"))))
|
||||
File diff suppressed because one or more lines are too long
@ -1,194 +0,0 @@
|
||||
#lang racket
|
||||
(require math/statistics sugar racket/serialize plot)
|
||||
(require (except-in "quads.rkt" line) "utils.rkt" "wrap.rkt" "world.rkt" "measure.rkt" "logger.rkt" "typeset.rkt")
|
||||
|
||||
(define+provide (make-wrap-proc-bps
|
||||
#:make-pieces-proc make-pieces-proc
|
||||
#:measure-quad-proc measure-quad-proc
|
||||
#:compose-line-proc compose-line-proc
|
||||
#:fast-measure-pieces-proc [fast-measure-pieces-proc (compose1 measure-quad-proc compose-line-proc)]
|
||||
#:find-breakpoints-proc find-breakpoints-proc)
|
||||
(λ(qs [measure #f])
|
||||
(let* ([measure (or measure (quad-attr-ref/parameter (car qs) world:measure-key))]
|
||||
[qs (if (quad-has-attr? (car qs) world:measure-key)
|
||||
qs
|
||||
(map (curryr quad-attr-set world:measure-key measure) qs))])
|
||||
(log-quad-debug "wrapping on measure = ~a" measure)
|
||||
(define pieces (make-pieces-proc qs))
|
||||
|
||||
(log-quad-debug "avg piece length for breakpoints = ~a"
|
||||
(/ (for/sum ([p (in-list pieces)])
|
||||
(for/sum ([q (in-list (quad-list p))])
|
||||
(define str (quad->string q))
|
||||
(if (equal? str "")
|
||||
(quad-attr-ref q world:width-key 0)
|
||||
(apply measure-text (quad->string q) (font-attributes-with-defaults q)))))
|
||||
(length pieces)))
|
||||
|
||||
(define bps (find-breakpoints-proc (list->vector pieces) (+ 0.0 measure)))
|
||||
(values pieces bps (map (curryr compose-line-proc measure-quad-proc) (break-at pieces bps))))))
|
||||
|
||||
;; wrap proc based on greedy proc
|
||||
(define wrap-first-bps (make-wrap-proc-bps
|
||||
#:make-pieces-proc (make-caching-proc make-pieces)
|
||||
#:measure-quad-proc quad-width
|
||||
#:compose-line-proc pieces->line
|
||||
#:fast-measure-pieces-proc measure-potential-line
|
||||
#:find-breakpoints-proc wrap-first))
|
||||
|
||||
;; wrap proc based on penalty function
|
||||
(define wrap-best-bps (make-wrap-proc-bps
|
||||
#:make-pieces-proc (make-caching-proc make-pieces)
|
||||
#:measure-quad-proc quad-width
|
||||
#:compose-line-proc pieces->line
|
||||
#:fast-measure-pieces-proc measure-potential-line
|
||||
#:find-breakpoints-proc wrap-best))
|
||||
|
||||
(define ti (block '(measure 54 leading 18) "Meg is an ally."))
|
||||
|
||||
|
||||
(define (looseness-spread lines)
|
||||
(if (<= (length lines) 1)
|
||||
0
|
||||
(let ([lines-to-measure (drop-right lines 1)]) ; exclude last line from looseness calculation
|
||||
(define measures (map (λ(line) (quad-attr-ref line world:line-looseness-key 0)) lines-to-measure))
|
||||
(round-float (- (apply max measures) (apply min measures))))))
|
||||
|
||||
(define (geometric-mean lines)
|
||||
(if (<= (length lines) 1)
|
||||
0
|
||||
(let ([lines-to-measure (drop-right lines 1)]) ; exclude last line from looseness calculation
|
||||
(define measures (map (λ(line) (quad-attr-ref line world:line-looseness-key 0)) lines-to-measure))
|
||||
(expt (apply * measures) (/ 1 (length measures))))))
|
||||
|
||||
(define (looseness-stddev lines)
|
||||
(if (<= (length lines) 1)
|
||||
0
|
||||
(let ([lines-to-measure (drop-right lines 1)]) ; exclude last line from looseness calculation
|
||||
(define measures (map (λ(line) (quad-attr-ref line world:line-looseness-key 0)) lines-to-measure))
|
||||
(stddev measures))))
|
||||
|
||||
(define (looseness-var lines)
|
||||
(if (<= (length lines) 1)
|
||||
0
|
||||
(let ([lines-to-measure (drop-right lines 1)]) ; exclude last line from looseness calculation
|
||||
(define measures (map (λ(line) (quad-attr-ref line world:line-looseness-key 0)) lines-to-measure))
|
||||
(variance measures))))
|
||||
|
||||
|
||||
|
||||
(define (list->hash0 . xs)
|
||||
(define mh (make-hash))
|
||||
(for ([(k v) (in-hash (apply hash xs))])
|
||||
(hash-set! mh k v))
|
||||
mh)
|
||||
|
||||
(define (piece-length p)
|
||||
(apply + (map quad-width (quad-list p))))
|
||||
|
||||
(define (trial wrap-proc ti measure)
|
||||
(match-define-values (result time _ _) (time-apply wrap-proc (append (list ti) (list measure))))
|
||||
(match-define (list pieces bps lines) result)
|
||||
(define line-count (length lines))
|
||||
(define piece-count (length pieces))
|
||||
(define avg-piece-length (/ (apply + (map piece-length pieces)) (length pieces)))
|
||||
(define avg-looseness (average-looseness lines))
|
||||
(define looseness-sd (looseness-stddev lines))
|
||||
(define looseness-variance (looseness-var lines))
|
||||
(define spread (looseness-spread lines))
|
||||
(define looses (map (λ(line) (quad-attr-ref line world:line-looseness-key 0)) lines))
|
||||
(hash 'bps bps 'time time 'line-count line-count 'looses looses
|
||||
'piece-count piece-count 'avg-piece-length avg-piece-length
|
||||
'avg-looseness avg-looseness 'looseness-spread spread
|
||||
'looseness-sd looseness-sd
|
||||
'looseness-variance looseness-variance))
|
||||
|
||||
|
||||
(define (improved? h1 h2)
|
||||
(define h1-bps (if (hash? h1) (hash-ref h1 'bps) h1))
|
||||
(define h2-bps (if (hash? h2) (hash-ref h2 'bps) h2))
|
||||
(define min-length (min (length h1-bps) (length h2-bps)))
|
||||
(apply + (map abs (map - (take h1-bps min-length) (take h2-bps min-length)))))
|
||||
|
||||
|
||||
(define (trial-set measure ti)
|
||||
(define text (quad->string ti))
|
||||
|
||||
(define ti-unhyphenated (split-quad ti))
|
||||
(define fu (trial wrap-first-bps ti-unhyphenated measure))
|
||||
(define bu (trial wrap-best-bps ti-unhyphenated measure))
|
||||
(define ti-hyphenated (split-quad (hyphenate-quad ti)))
|
||||
(define fh (trial wrap-first-bps ti-hyphenated measure))
|
||||
(define bh (trial wrap-best-bps ti-hyphenated measure))
|
||||
|
||||
(hash 'fu fu 'bu bu 'fh fh 'bh bh
|
||||
'text text
|
||||
'measure measure
|
||||
'fh-improved (improved? fu fh)
|
||||
'bu-improved (improved? fu bu)
|
||||
'bh-improved (improved? fh bh)))
|
||||
|
||||
(define (make-blocks textfile)
|
||||
(define strings (filter (λ(s) (> (string-length s) 10)) (map (λ(s) (regexp-replace* #rx"\n" s " ")) (map string-trim (string-split (file->string textfile) "\n\n")))))
|
||||
(map (λ(t) (block '(font "Equity Text B" leading 14 column-count 1 column-gutter 10 size 11.5 x-align justify x-align-last-line left) t)) strings))
|
||||
|
||||
(define (refresh [filename "jude0.txt"] [measures '(150 180 210 240 270 300 330 360 390)])
|
||||
(define paragraphs (make-blocks filename))
|
||||
;; only use paragraphs > 2 lines because last line is disregarded for looseness spread calculation
|
||||
(define results (filter
|
||||
(λ(rec) (> (hash-ref (hash-ref rec 'fu) 'line-count) 2)) (append-map (compose1 (λ(m) (map (λ(p) (trial-set m p)) paragraphs)) (λ(m) (report m))) measures)))
|
||||
(write-to-file (serialize results) "stats-data.txt" #:exists 'replace))
|
||||
|
||||
(define (load-data-records)
|
||||
(deserialize (file->value "stats-data.txt")))
|
||||
|
||||
(define recs (load-data-records))
|
||||
|
||||
(define (plot-lists xs ys zs kx ky kz)
|
||||
(parameterize ([plot-width 700]
|
||||
[plot-height 700]
|
||||
[plot-x-label kx]
|
||||
[plot-y-label ky]
|
||||
[plot-z-label kz])
|
||||
(plot3d
|
||||
;#:x-max 2 #:x-min -2
|
||||
#:y-min 140 #:y-max 400
|
||||
#:z-max 1.5
|
||||
#:angle 0
|
||||
#:altitude 32
|
||||
(points3d (map vector xs ys zs)
|
||||
#:sym 'fullcircle7
|
||||
#:alpha 0.1
|
||||
#:color 42))))
|
||||
|
||||
(define (fu-formula rec)
|
||||
(define pieces-per-line (/ (hash-ref (hash-ref rec 'fu) 'piece-count)
|
||||
(hash-ref (hash-ref rec 'fu) 'line-count) 1.0))
|
||||
(+ 2.2 (log (abs (hash-ref (hash-ref rec 'fu) 'looseness-sd)))
|
||||
(* 0.09 pieces-per-line)))
|
||||
|
||||
(define (geo-mean rec)
|
||||
(define looses (hash-ref (hash-ref rec 'fu) 'looses))
|
||||
(expt (abs (apply * looses)) (/ 1 (length looses))))
|
||||
|
||||
(define (magic2 rec)
|
||||
(define looses (map abs (hash-ref (hash-ref rec 'fu) 'looses)))
|
||||
(expt (log (+ 1 (/ (variance looses) (expt (mean looses) 2)))) 0.5))
|
||||
|
||||
|
||||
(define (plot-it)
|
||||
(define-values (helped or-not) (partition (λ(rec) (< 0 (hash-ref rec 'bu-improved))) recs))
|
||||
(define-values (fu-pos fu-neg) (partition (λ(rec) (> (fu-formula rec) 0)) recs))
|
||||
(report* (length helped) (length or-not) (length fu-pos) (length fu-neg))
|
||||
(let ([recs recs])
|
||||
(plot-lists
|
||||
(map fu-formula recs)
|
||||
(map (λ(rec) (hash-ref rec 'measure)) recs)
|
||||
(map (λ(rec) (if (= 0 (hash-ref rec 'bu-improved)) 0 1)) recs) "fu-formula" "measure" "improve?")))
|
||||
|
||||
(plot-it)
|
||||
|
||||
(define (looseness-improvement rec)
|
||||
(/ (abs (- (hash-ref (hash-ref rec 'bu) 'avg-looseness) (hash-ref (hash-ref rec 'fu) 'avg-looseness)))
|
||||
(hash-ref (hash-ref rec 'bu) 'avg-looseness)))
|
||||
(define zs (filter positive? (sort (map looseness-improvement recs) <)))
|
||||
@ -1,3 +0,0 @@
|
||||
#lang quad
|
||||
|
||||
◊block['(measure 240.0 font "Times New Roman" leading 16.0 vmeasure 300.0 size 13.5 x-align justify x-align-last-line left)]{My Fellow Americans.}
|
||||
@ -1,3 +0,0 @@
|
||||
#lang quad
|
||||
|
||||
◊block[#f]{hi there everyone}
|
||||
@ -1,2 +0,0 @@
|
||||
#lang racket
|
||||
(require "test-quadlangmod.rkt")
|
||||
@ -1,79 +0,0 @@
|
||||
#lang racket/base
|
||||
(require racket/list racket/function rackunit "ocm.rkt" sugar)
|
||||
|
||||
|
||||
(define (vector-range n)
|
||||
(build-vector n identity))
|
||||
|
||||
(define (random-ascending len start finish)
|
||||
(if (= len 0)
|
||||
null
|
||||
(let ([r (+ start (random (- finish start)))])
|
||||
(cons r (random-ascending (sub1 len) r finish)))))
|
||||
|
||||
|
||||
(define (concave-list len min [lowval 0][highval 100])
|
||||
(append (reverse (random-ascending min lowval highval)) (random-ascending (- len min) lowval highval)))
|
||||
|
||||
|
||||
(define (make-matrix2 rows cols)
|
||||
(define row-minima-indexes (random-ascending rows 0 cols))
|
||||
(reverse (for/list ([row-minima-index (in-list row-minima-indexes)])
|
||||
(concave-list cols row-minima-index 20 400))))
|
||||
|
||||
|
||||
(define (make-matrix rows cols)
|
||||
(define seed (for/list ([i (in-range (max rows cols))])
|
||||
(random 100)))
|
||||
(for/list ([i (in-range rows)])
|
||||
(for/list ([j (in-range cols)])
|
||||
(if (< i j)
|
||||
(apply + (sublist seed i (add1 j)))
|
||||
(apply + (sublist seed j (add1 i)))))))
|
||||
|
||||
|
||||
(define (make-matrix-proc m [is (range (length m))] [js (range (length (car m)))])
|
||||
(let ([ipairs (apply hash (flatten (map cons is (range (length is)))))]
|
||||
[jpairs (apply hash (flatten (map cons js (range (length js)))))])
|
||||
(λ(i j)
|
||||
(define my-i (hash-ref ipairs i))
|
||||
(define my-j (hash-ref jpairs j))
|
||||
(with-handlers [(exn:fail? (λ(exn) (* -1 i)))]
|
||||
(list-ref (list-ref m my-i) my-j)))))
|
||||
|
||||
|
||||
(define (compare-reductions m)
|
||||
(check-equal?
|
||||
(reduce2 (vector-range (length m)) (vector-range (length (car m))) (make-matrix-proc m) identity)
|
||||
(reduce (vector-range (length m)) (vector-range (length (car m))) (make-matrix-proc m) identity)))
|
||||
|
||||
|
||||
(define (do-it x)
|
||||
(repeat x
|
||||
(define rows (+ 2 (random 40)))
|
||||
(define cols (+ 2 (random rows)))
|
||||
(define m (make-matrix rows cols))
|
||||
(check-true (smawky? m))
|
||||
(compare-reductions m)))
|
||||
|
||||
(define me '((25 21 13 10 20 13 19 35 37 41 58 66 82 99 124 133 156 178) (42 35 26 20 29 21 25 37 36 39 56 64 76 91 116 125 146 164) (57 48 35 28 33 24 28 40 37 37 54 61 72 83 107 113 131 146) (78 65 51 42 44 35 38 48 42 42 55 61 70 80 100 106 120 135) (90 76 58 48 49 39 42 48 39 35 47 51 56 63 80 86 97 110) (103 85 67 56 55 44 44 49 39 33 41 44 49 56 71 75 84 96) (123 105 86 75 73 59 57 62 51 44 50 52 55 59 72 74 80 92) (142 123 100 86 82 65 61 62 50 43 47 45 46 46 58 59 65 73) (151 130 104 88 80 59 52 49 37 29 29 24 23 20 28 25 31 39)))
|
||||
|
||||
|
||||
|
||||
(define (bug-test bugmatrix bugrows bugcols)
|
||||
(define bugproc (make-matrix-proc bugmatrix bugrows bugcols))
|
||||
(check-equal? (reduce (list->vector bugrows) (list->vector bugcols) bugproc identity)
|
||||
(reduce2 (list->vector bugrows) (list->vector bugcols) bugproc identity)))
|
||||
|
||||
|
||||
(bug-test '((19496.0 14025.0 7134.0 5027.0) (108793.0 102427.0 93819.0 90268.0) (101409.0 93357.0 81509.0 75236.0) (106662.0 93357.0 71417.0 56665.0))
|
||||
'(0 1 2 3)
|
||||
'(4 5 6 7))
|
||||
|
||||
|
||||
(bug-test '((25 42 57 78 90 103 123 142 151) (21 35 48 65 76 85 105 123 130) (13 26 35 51 58 67 86 100 104) (10 20 28 42 48 56 75 86 88) (20 29 33 44 49 55 73 82 80) (13 21 24 35 39 44 59 65 59) (19 25 28 38 42 44 57 61 52) (35 37 40 48 48 49 62 62 49) (37 36 37 42 39 39 51 50 37) (41 39 37 42 35 33 44 43 29) (58 56 54 55 47 41 50 47 29) (66 64 61 61 51 44 52 45 24) (82 76 72 70 56 49 55 46 23) (99 91 83 80 63 56 59 46 20) (124 116 107 100 80 71 72 58 28) (133 125 113 106 86 75 74 59 25) (156 146 131 120 97 84 80 65 31) (178 164 146 135 110 96 92 73 39))
|
||||
'(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17)
|
||||
'(0 1 2 3 4 5 6 7 8))
|
||||
|
||||
|
||||
(do-it 10)
|
||||
@ -1,95 +0,0 @@
|
||||
#lang racket/base
|
||||
(require "utils.rkt" "wrap.rkt" "quads.rkt" "world.rkt" racket/list racket/format)
|
||||
(require rackunit)
|
||||
|
||||
(check-equal? (join-attrs (list (box '(width 10)) (box '() "foobar") (hash 'x 10) (list 'width 20)))
|
||||
(list (cons 'width 10) (cons 'x 10) (cons 'width 20)))
|
||||
|
||||
(check-equal? (flatten-attrs (hash 'foo 'bar) (hash 'x 10)) (apply hash '(foo bar x 10)))
|
||||
(check-equal? (flatten-attrs (hash 'x -5) (hash 'x 10)) (apply hash '(x 5)))
|
||||
(check-equal? (merge-attrs (hash 'x -5) (hash 'x 10)) (apply hash '(x 10)))
|
||||
|
||||
(check-equal? (gather-common-attrs (list (box '(foo bar)) (box '(foo bar goo bar zam zino)) (box '(foo bar)))) '(foo bar))
|
||||
(check-equal? (gather-common-attrs (list (box) (box '(foo bar goo bar zam zino)) (box '(foo bar)))) '())
|
||||
(check-equal? (gather-common-attrs (list (box '(width bar)) (box '(width bar)) (box '(width bar)))) '())
|
||||
|
||||
(define b1 (box '(x 10) "1st" (box '(foo bar) "2nd") "3rd"))
|
||||
(define b1-flattened (list (box '(x 10) "1st") (box '(x 10 foo bar) "2nd") (box '(x 10) "3rd")))
|
||||
|
||||
|
||||
(define b3 (box '() (word) (line) (page)))
|
||||
(check-true (sequence? b3))
|
||||
;(check-equal? (for/list ([i (in-quad b3)]) i) (list (word) (line) (page)))
|
||||
|
||||
(check-true (quad= (flatten-quad b1) b1-flattened))
|
||||
|
||||
(define b2 (box '(x 10) (spacer) (box '(x 15) (spacer) (spacer)) (spacer)))
|
||||
(define b2-flattened (list (spacer '(x 10)) (spacer '(x 25)) (spacer '(x 25)) (spacer '(x 10))))
|
||||
|
||||
(check-true (quad= (flatten-quad b2) b2-flattened))
|
||||
(check-true (quad= (split-quad b2) b2-flattened))
|
||||
|
||||
(check-true (quad= (flatten-quad (box '(foo 10) (spacer) (box) (spacer))) (list (spacer '(foo 10)) (box '(foo 10)) (spacer '(foo 10)))))
|
||||
|
||||
|
||||
(check-equal? (compute-absolute-positions (page '(x 100 y 100) (line '(x 10 y 10) (word '(x 1 y 1) "hello")
|
||||
(word '(x 2 y 2) "world"))))
|
||||
(page '(y 100.0 x 100.0) (line '(y 110.0 x 110.0) (word '(y 111.0 x 111.0) "hello")(word '(y 112.0 x 112.0) "world"))))
|
||||
|
||||
|
||||
(define b2-exploded (list (word '(x 10) "1") (word '(x 10) "s") (word '(x 10) "t") (word '(x 10 foo bar) "2") (word '(x 10 foo bar) "n") (word '(x 10 foo bar) "d") (word '(x 10) "3") (word '(x 10) "r") (word '(x 10) "d")))
|
||||
|
||||
(check-true (quad= (split-quad b1) b2-exploded))
|
||||
|
||||
|
||||
(check-false (quad-has-attr? (box) 'foo))
|
||||
(check-true (quad-has-attr? (box '(foo bar)) 'foo))
|
||||
|
||||
(check-equal? (quad-attr-set (box '(foo bar)) 'foo 'zam) (box '(foo zam)))
|
||||
(check-equal? (quad-attr-set (box '()) 'foo 'zam) (box '(foo zam)))
|
||||
(check-equal? (quad-attr-set* (box '()) 'foo 'zam 'bar 'boo) (box '(foo zam bar boo)))
|
||||
(check-equal? (quad-attr-set* (box '(foo bar)) 'foo 'zam 'bar 'boo) (box '(foo zam bar boo)))
|
||||
|
||||
(check-equal? (quad-attr-remove (box '(foo bar zim zam)) 'foo) (box '(zim zam)))
|
||||
(check-equal? (quad-attr-remove (box '()) 'zim) (box))
|
||||
(check-equal? (quad-attr-remove* (box '(foo bar zim zam ding dong)) 'foo 'ding) (box '(zim zam)))
|
||||
(check-equal? (quad-attr-remove* (box '()) 'zim) (box))
|
||||
|
||||
(check-true (quad-ends-with? (box '() "foo") "foo"))
|
||||
(check-false (quad-ends-with? (box '() "foo") "food"))
|
||||
(check-false (quad-ends-with? (box '() (box '() "foo")) "food"))
|
||||
(check-true (quad-ends-with? (box '() (box '() "foo")) "foo"))
|
||||
(check-true (quad-ends-with? (box '() (box '() "foo")) "o"))
|
||||
(check-true (quad-ends-with? (box '() (box '() (box '() (box '() (box '() "foo-"))))) "-"))
|
||||
|
||||
(check-equal? (quad-append (box '() "foo") "bar") (box '() "foo" "bar"))
|
||||
(check-equal? (quad-append (box '() "foo") (box '() "bar")) (box '() "foo" (box '() "bar")))
|
||||
|
||||
(check-equal? (quad-last-char (box '() (box '() "foo") "food")) "d")
|
||||
(check-equal? (quad-last-char (box '() (box '() "foo"))) "o")
|
||||
(check-equal? (quad-last-char (box '() "foo")) "o")
|
||||
(check-false (quad-last-char (box)))
|
||||
|
||||
(check-equal? (quad-first-char (box '() (box '() "foo") "bar")) "f")
|
||||
(check-equal? (quad-first-char (box '() (box '() "foo") "bar")) "f")
|
||||
(check-equal? (quad-first-char (box '() "foo")) "f")
|
||||
(check-false (quad-first-char (box)))
|
||||
|
||||
(check-equal? (quad->string (box '(width 100) "foo")) "foo")
|
||||
(check-equal? (quad->string (box '(width 100) "foo" (box '(width 100) "bar"))) "foobar")
|
||||
(check-equal? (quad->string (box '(width 100) "foo" (box '(width 100) "bar") "ino")) "foobarino")
|
||||
(check-equal? (quad->string (box '(width 100))) "")
|
||||
|
||||
|
||||
(check-false (whitespace? (~a #\u00A0)))
|
||||
(check-true (whitespace/nbsp? (~a #\u00A0)))
|
||||
(check-true (whitespace/nbsp? (word '() (~a #\u00A0))))
|
||||
(check-false (whitespace? (format " ~a " #\u00A0)))
|
||||
(check-true (whitespace/nbsp? (format " ~a " #\u00A0)))
|
||||
(define funny-unicode-spaces (map ~a (list #\u2000 #\u2007 #\u2009 #\u200a #\u202f)))
|
||||
(check-true (andmap whitespace? funny-unicode-spaces))
|
||||
(check-true (andmap whitespace/nbsp? funny-unicode-spaces))
|
||||
|
||||
|
||||
(let ([world:minimum-last-line-chars 0])
|
||||
(check-equal? (map (compose1 quad-list last quad-list) (make-pieces (split-quad (block '() "Foo-dog and " (box) " mas\u00adsachu.")))) '(("o") ("g") ("d") () ("s") ("."))))
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,12 +0,0 @@
|
||||
#lang racket/base
|
||||
|
||||
;; todo next
|
||||
;; pagination: vertical measuring
|
||||
;; adaptive linebreak using fu-formula
|
||||
;; unified model of filling / positioning that works for every quad, recursively
|
||||
;; how to handle constraint failure. At least a good error message.
|
||||
;; imperative line break
|
||||
;; why do certain MB fonts only appear in bold?
|
||||
;; deal with separating / recombining footnote flow
|
||||
;; deal with page number flags (for toc, index, etc)
|
||||
;; disk cache of previously wrapped lines
|
||||
@ -1,213 +0,0 @@
|
||||
#lang racket/base
|
||||
(require racket/list sugar racket/contract racket/function math/flonum)
|
||||
(require "quads.rkt" "utils.rkt" "wrap.rkt" "measure.rkt" "world.rkt" "logger.rkt")
|
||||
(provide typeset)
|
||||
(require sugar/debug)
|
||||
(define (input->nested-blocks i)
|
||||
(define-syntax-rule (cons-reverse x y) (cons (reverse x) y))
|
||||
(define-values (mps mcs bs b)
|
||||
(for/fold ([multipages empty][multicolumns empty][blocks empty][block-acc empty])
|
||||
([q (in-list (split-quad i))])
|
||||
(cond
|
||||
[(page-break? q) (values (cons-reverse (cons-reverse (cons-reverse block-acc blocks) multicolumns) multipages) empty empty empty)]
|
||||
[(column-break? q) (values multipages (cons-reverse (cons-reverse block-acc blocks) multicolumns) empty empty)]
|
||||
[(block-break? q) (values multipages multicolumns (cons-reverse block-acc blocks) empty)]
|
||||
[else (values multipages multicolumns blocks (cons q block-acc))])))
|
||||
(reverse (cons-reverse (cons-reverse (cons-reverse b bs) mcs) mps)))
|
||||
|
||||
(define (merge-adjacent-within q)
|
||||
(quad (quad-name q) (quad-attrs q) (join-quads (quad-list q))))
|
||||
|
||||
(define (hyphenate-quad-except-last-word q)
|
||||
(log-quad-debug "last word will not be hyphenated")
|
||||
(define-values (first-quads last-quad) (split-last (quad-list q)))
|
||||
(quad (quad-name q) (quad-attrs q) (snoc (map hyphenate-quad first-quads) last-quad)))
|
||||
|
||||
(define+provide (average-looseness lines)
|
||||
(if (<= (length lines) 1)
|
||||
0.0
|
||||
(let ([lines-to-measure (drop-right lines 1)]) ; exclude last line from looseness calculation
|
||||
(round-float (fl/ (fold-fl+ (map (λ(line) (quad-attr-ref line world:line-looseness-key 0.0)) lines-to-measure)) (fl- (fl (length lines)) 1.0))))))
|
||||
|
||||
|
||||
(define (log-debug-lines lines)
|
||||
(log-quad-debug "line report:")
|
||||
(for/list ([(line idx) (in-indexed lines)])
|
||||
(format "~a/~a: ~v ~a" idx
|
||||
(length lines)
|
||||
(quad->string line)
|
||||
(quad-attr-ref line world:line-looseness-key))))
|
||||
|
||||
|
||||
(require racket/trace)
|
||||
(define (block->lines b)
|
||||
(define quality (quad-attr-ref/parameter b world:quality-key))
|
||||
(define (wrap-quads qs)
|
||||
(define wrap-proc (cond
|
||||
[(>= quality world:max-quality) wrap-best]
|
||||
[(<= quality world:draft-quality) wrap-first]
|
||||
[else wrap-adaptive]))
|
||||
(wrap-proc qs))
|
||||
(log-quad-debug "wrapping lines")
|
||||
(log-quad-debug "quality = ~a" quality)
|
||||
(log-quad-debug "looseness tolerance = ~a" world:line-looseness-tolerance)
|
||||
(define wrapped-lines-without-hyphens (wrap-quads (quad-list b))) ; 100/150
|
||||
(log-quad-debug* (log-debug-lines wrapped-lines-without-hyphens))
|
||||
(define avg-looseness (average-looseness wrapped-lines-without-hyphens))
|
||||
(define gets-hyphenation? (and world:use-hyphenation?
|
||||
(fl> avg-looseness world:line-looseness-tolerance)))
|
||||
(log-quad-debug "average looseness = ~a" avg-looseness)
|
||||
(log-quad-debug (if gets-hyphenation? "hyphenating" "no hyphenation needed"))
|
||||
|
||||
(define wrapped-lines (if gets-hyphenation?
|
||||
(wrap-quads (split-quad ((if world:allow-hyphenated-last-word-in-paragraph
|
||||
hyphenate-quad
|
||||
hyphenate-quad-except-last-word) (merge-adjacent-within b))))
|
||||
wrapped-lines-without-hyphens))
|
||||
|
||||
(when gets-hyphenation? (log-quad-debug* (log-debug-lines wrapped-lines)))
|
||||
|
||||
|
||||
(log-quad-debug "final looseness = ~a" (average-looseness wrapped-lines))
|
||||
(map insert-spacers-in-line
|
||||
(for/list ([line-idx (in-naturals)][line (in-list wrapped-lines)])
|
||||
(quad-attr-set* line 'line-idx line-idx 'lines (length wrapped-lines)))))
|
||||
|
||||
|
||||
(define+provide (number-pages ps)
|
||||
(pages? . -> . pages?)
|
||||
(for/list ([i (in-naturals)][p (in-list ps)])
|
||||
(quad (quad-name p) (merge-attrs (quad-attrs p) `(page ,i)) (quad-list p))))
|
||||
|
||||
(define+provide (pages->doc ps)
|
||||
(pages? . -> . doc?)
|
||||
;; todo: resolve xrefs and other last-minute tasks
|
||||
;; todo: generalize computation of widths and heights, recursively
|
||||
(define (columns-mapper page)
|
||||
(quad-map (compose1 add-vert-positions (curry quad-map (compose1 compute-line-height add-horiz-positions fill))) page))
|
||||
(define mapped-pages (map columns-mapper (number-pages ps)))
|
||||
(define doc (quads->doc mapped-pages))
|
||||
doc)
|
||||
|
||||
(require racket/class csp)
|
||||
(define+provide (lines->columns lines)
|
||||
(lines? . -> . columns?)
|
||||
(define prob (new problem%))
|
||||
(define max-column-lines world:default-lines-per-column)
|
||||
(define-values (columns ignored-return-value)
|
||||
(for/fold ([columns null][lines-remaining lines])([col-idx (in-naturals)] #:break (empty? lines-remaining))
|
||||
(log-quad-info "making column ~a" (add1 col-idx))
|
||||
;; domain constraint is best way to simplify csp, because it limits the search space.
|
||||
;; search from largest possible value to smallest.
|
||||
;; largest possible is the minimum of the max column lines, or
|
||||
;; the number of lines left (modulo minimum page lines) ...
|
||||
(define viable-column-range
|
||||
(range (min max-column-lines (max
|
||||
(length lines-remaining)
|
||||
(- (length lines-remaining) world:minimum-lines-per-column)))
|
||||
;; ... and the smallest possible is 1, or the current minimum lines.
|
||||
;; (sub1 insures that range is inclusive of last value.)
|
||||
(sub1 (min 1 world:minimum-lines-per-column)) -1))
|
||||
|
||||
(log-quad-debug "viable number of lines for this column to start =\n~a" viable-column-range)
|
||||
(send prob add-variable "column-lines" viable-column-range)
|
||||
|
||||
|
||||
;; greediness constraint: leave enough lines for next page, or take all
|
||||
(define (greediness-constraint pl)
|
||||
(define leftover (- (length lines-remaining) pl))
|
||||
(or (= leftover 0) (>= leftover world:minimum-lines-per-column)))
|
||||
(send prob add-constraint greediness-constraint '("column-lines"))
|
||||
|
||||
(log-quad-debug "viable number of lines after greediness constraint =\n~a" (map (curryr hash-ref "column-lines") (send prob get-solutions)))
|
||||
|
||||
;; last lines constraint: don't take page that will end with too few lines of last paragraph.
|
||||
(define (last-lines-constraint pl)
|
||||
(define last-line-of-page (list-ref lines-remaining (sub1 pl)))
|
||||
(define lines-in-this-paragraph (quad-attr-ref last-line-of-page world:total-lines-key))
|
||||
(define line-index-of-last-line (quad-attr-ref last-line-of-page world:line-index-key))
|
||||
(define (paragraph-too-short-to-meet-constraint?)
|
||||
(< lines-in-this-paragraph world:min-last-lines))
|
||||
(or (paragraph-too-short-to-meet-constraint?)
|
||||
(>= (add1 line-index-of-last-line) world:min-last-lines)))
|
||||
(send prob add-constraint last-lines-constraint '("column-lines"))
|
||||
|
||||
(log-quad-debug "viable number of lines after last-lines constraint =\n~a" (map (curryr hash-ref "column-lines") (send prob get-solutions)))
|
||||
|
||||
;; first lines constraint: don't take page that will leave too few lines at top of next page
|
||||
(define (first-lines-constraint pl lines-remaining)
|
||||
(define last-line-of-page (list-ref lines-remaining (sub1 pl)))
|
||||
(define lines-in-this-paragraph (quad-attr-ref last-line-of-page world:total-lines-key))
|
||||
(define line-index-of-last-line (quad-attr-ref last-line-of-page world:line-index-key))
|
||||
(define lines-that-will-remain (- lines-in-this-paragraph (add1 line-index-of-last-line)))
|
||||
(define (paragraph-too-short-to-meet-constraint?)
|
||||
(< lines-in-this-paragraph world:min-first-lines))
|
||||
(or (paragraph-too-short-to-meet-constraint?)
|
||||
(= 0 lines-that-will-remain) ; ok to use all lines ...
|
||||
(>= lines-that-will-remain world:min-first-lines))) ; but if any remain, must be minimum number.
|
||||
(send prob add-constraint (curryr first-lines-constraint lines-remaining) '("column-lines"))
|
||||
|
||||
(log-quad-debug "viable number of lines after first-lines constraint =\n~a" (map (curryr hash-ref "column-lines") (send prob get-solutions)))
|
||||
|
||||
|
||||
(define s (send prob get-solution))
|
||||
(define how-many-lines-to-take (hash-ref s "column-lines"))
|
||||
(define-values (lines-to-take lines-to-leave) (split-at lines-remaining how-many-lines-to-take))
|
||||
(log-quad-debug "taking ~a lines for column ~a:" how-many-lines-to-take (add1 col-idx))
|
||||
(map (λ(idx line) (log-quad-debug "~a:~a ~v" (add1 col-idx) (add1 idx) (quad->string line))) (range how-many-lines-to-take) lines-to-take)
|
||||
(send prob reset)
|
||||
(values (cons (quad-attr-set (quads->column lines-to-take) world:column-index-key col-idx) columns) lines-to-leave)))
|
||||
(reverse columns))
|
||||
|
||||
(define (columns->pages cols)
|
||||
(columns? . -> . pages?)
|
||||
(define columns-per-page (quad-attr-ref/parameter (car cols) world:column-count-key))
|
||||
(define column-gutter (quad-attr-ref/parameter (car cols) world:column-gutter-key))
|
||||
;; don't use default value here. If the col doesn't have a measure key,
|
||||
;; it deserves to be an error, because that means the line was composed incorrectly.
|
||||
(when (not (quad-has-attr? (car cols) world:measure-key))
|
||||
(error 'columns->pages "column attrs contain no measure key: ~a ~a" (quad-attrs (car cols)) (quad-car (car cols))))
|
||||
(define column-width (quad-attr-ref (car cols) world:measure-key))
|
||||
(define width-of-printed-area (+ (* columns-per-page column-width) (* (sub1 columns-per-page) column-gutter)))
|
||||
(define result-pages
|
||||
(map (λ(cols) (quads->page cols))
|
||||
(for/list ([page-cols (in-list (slice-at cols columns-per-page))])
|
||||
(define-values (last-x cols)
|
||||
(for/fold ([current-x (/ (- (world:paper-width-default) width-of-printed-area) 2)][cols empty]) ([col (in-list page-cols)][idx (in-naturals)])
|
||||
(values (+ current-x column-width column-gutter) (cons (quad-attr-set* col 'x current-x 'y world:top-page-margin world:column-index-key idx) cols))))
|
||||
(reverse cols))))
|
||||
result-pages)
|
||||
|
||||
(define current-eof (make-parameter (gensym)))
|
||||
(define (eof? x) (equal? x (current-eof)))
|
||||
|
||||
|
||||
|
||||
(define (block-quads->lines qs)
|
||||
(block->lines (quads->block qs)))
|
||||
|
||||
(define (typeset x)
|
||||
(coerce/input? . -> . doc?)
|
||||
(load-text-cache-file)
|
||||
(define pages (append* (for/list ([multipage (in-list (input->nested-blocks x))])
|
||||
(columns->pages (append* (for/list ([multicolumn (in-list multipage)])
|
||||
(lines->columns (append* (for/list ([block-quads (in-list multicolumn)])
|
||||
(block-quads->lines block-quads))))))))))
|
||||
(define doc (pages->doc pages))
|
||||
(update-text-cache-file)
|
||||
doc)
|
||||
|
||||
|
||||
(module+ main
|
||||
(require "render.rkt" racket/class profile sugar/debug)
|
||||
(require "samples.rkt")
|
||||
(activate-logger quad-logger)
|
||||
(parameterize ([world:quality-default world:draft-quality]
|
||||
[world:paper-width-default 600]
|
||||
[world:paper-height-default 700])
|
||||
#;(define sample (block '(measure 54.0 leading 18.0) "\n" "\n" "Meg is an ally."))
|
||||
(let ([toa (begin (time (typeset (dynamic-require "foo2.rkt" 'out))))]
|
||||
[tob (typeset (block '(measure 54.0 leading 18.0) "Meg \nis an ally."))])
|
||||
(report* toa tob (equal? toa tob))
|
||||
(time (send (new pdf-renderer%) render-to-file toa "foo-a.pdf"))
|
||||
(time (send (new pdf-renderer%) render-to-file tob "foo-b.pdf")))))
|
||||
@ -1,5 +0,0 @@
|
||||
#lang racket/base
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define current-default-attrs (make-parameter (make-hasheq)))
|
||||
(define current-line-width (make-parameter 1))
|
||||
@ -1,4 +0,0 @@
|
||||
#lang quad/text pdf 360 300
|
||||
@quad[(make-attrs #:font "Charter.ttf")]{Not that you need to be a programmer to start using Pollen. On the contrary, the Pollen language is markup-based, so you can write & edit text naturally. But when you want to automate repetitive tasks, add cross-references, or pull in data from other sources, you can access a full programming language from within the text.
|
||||
|
||||
Not that you need to be a programmer to start using Pollen. On the contrary, the Pollen language is markup-based, so you can write & edit text naturally. But when you want to automate repetitive tasks, add cross-references, or pull in data from other sources, you can access a full programming language from within the text.}
|
||||
@ -1,127 +0,0 @@
|
||||
#lang racket/base
|
||||
(provide (all-defined-out))
|
||||
(require racket/string racket/list (for-syntax racket/base racket/syntax))
|
||||
|
||||
(struct $quad (attrs dim val) #:transparent #:mutable)
|
||||
(struct $black $quad () #:transparent)
|
||||
(struct $space $quad () #:transparent)
|
||||
(struct $hyphen $black () #:transparent) ; hyphen should be treated as black in measure & render ops
|
||||
(struct $shy $quad () #:transparent)
|
||||
(struct $shim $quad () #:transparent)
|
||||
(struct $eof $quad () #:transparent)
|
||||
|
||||
(define (quad-printable? x) (or ($black? x) ($space? x) ($hyphen? x)))
|
||||
|
||||
(define quad? $quad?)
|
||||
|
||||
(define quad-attrs $quad-attrs)
|
||||
(define quad-val $quad-val)
|
||||
|
||||
(define (quad-attrs? x) (list? x))
|
||||
|
||||
|
||||
#|
|
||||
Attrs needed to specify rendered appearance:
|
||||
(font) family
|
||||
(font) style
|
||||
(font) size
|
||||
color
|
||||
background
|
||||
position
|
||||
measure (line width)
|
||||
|
||||
|#
|
||||
(define default-attrs (hasheq 'size 10 'font "sc.otf")) ; Source Code Pro, 12 pt, chars are 6pt wide
|
||||
|
||||
(define (munge-whitespace str)
|
||||
;; reduce multiple whitespace to single
|
||||
;; trim remaining (? maybe not)
|
||||
(regexp-replace* #px"\\s+" str " "))
|
||||
|
||||
(define (merge-strings xs)
|
||||
;; merge consecutive strings
|
||||
;; todo: only trim remove space between string and a hard break.
|
||||
;; space between a string and a subquad is ok
|
||||
(let loop ([xs xs])
|
||||
(cond
|
||||
[(empty? xs) empty]
|
||||
[else
|
||||
(define-values (strs rest) (splitf-at xs string?))
|
||||
(define-values (nonstrs restrest) (splitf-at rest (λ(x) (not (string? x)))))
|
||||
(append (if (empty? strs)
|
||||
empty
|
||||
(list (munge-whitespace (string-append* strs)))) nonstrs (loop restrest))])))
|
||||
|
||||
|
||||
(struct $attrs (size font) #:transparent)
|
||||
(define (make-attrs #:size [size #f]
|
||||
#:font [font #f])
|
||||
(hasheq 'size size 'font font))
|
||||
|
||||
(define (make-empty-attrs) (make-attrs))
|
||||
|
||||
|
||||
|
||||
(define (quad attr . xs)
|
||||
;; squeeze excess whitespace out of quad args
|
||||
;; todo: find way to do this with less allocation
|
||||
($quad (or attr (make-attrs)) 0 (merge-strings xs)))
|
||||
|
||||
|
||||
(define (quad-dim q)
|
||||
($quad-dim q))
|
||||
|
||||
(define (quad-font q)
|
||||
(hash-ref (quad-attrs q) 'font))
|
||||
(define (quad-font-size q)
|
||||
(hash-ref (quad-attrs q) 'size))
|
||||
|
||||
(define (quad-dim-set! q val)
|
||||
(set-$quad-dim! q val))
|
||||
|
||||
(define (override-with dest source)
|
||||
;; replace missing values in dest with values from source
|
||||
(for/hasheq ([k (in-hash-keys source)])
|
||||
(values k (or (hash-ref dest k) (hash-ref source k)))))
|
||||
|
||||
(require (for-syntax sugar/debug))
|
||||
(define-syntax-rule (define-break name)
|
||||
(define (name) ($shim (make-attrs) 'name #f)))
|
||||
|
||||
(define-break page-break)
|
||||
(define-break column-break)
|
||||
(define-break block-break)
|
||||
(define-break line-break)
|
||||
|
||||
(define-syntax (define-case-macro stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ID PRED)
|
||||
#'(define-syntax (ID stx)
|
||||
(syntax-case stx ()
|
||||
[(_ test-val
|
||||
[(match-val0 . match-vals) . result] (... ...)
|
||||
[else . else-result])
|
||||
#'(cond
|
||||
[(PRED test-val '(match-val0 . match-vals)) . result] (... ...)
|
||||
[else . else-result])]
|
||||
[(_ test-val
|
||||
match-clause (... ...))
|
||||
#'(ID test-val
|
||||
match-clause (... ...)
|
||||
[else (error 'ID "no match")])]))]))
|
||||
|
||||
;; like case but strictly uses `eq?` comparison (as opposed to `equal?`)
|
||||
(define-case-macro caseq memq)
|
||||
|
||||
;; `eqv?` is OK for chars (same as `char=?`)
|
||||
(define-case-macro casev memv)
|
||||
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(define q (quad #f "bar"))
|
||||
(check-true (quad? q))
|
||||
(check-false (quad? 42))
|
||||
(check-equal? (quad-attrs q) (make-attrs))
|
||||
(check-equal? (quad-val q) '("bar"))
|
||||
#;(check-equal? (merge-strings '(50 " foo " " bar " 42 " zam")) '(50 "foo bar" 42 "zam")))
|
||||
@ -1,101 +0,0 @@
|
||||
#lang quad/dev
|
||||
(require racket/class racket/contract racket/string sugar/debug sugar/cache racket/list racket/file racket/draw data/gvector)
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define (world:paper-width-default) 612)
|
||||
(define (world:paper-height-default) 792)
|
||||
|
||||
(define renderable-quads '(word box))
|
||||
|
||||
(define (render-pdf [qs #f] [path-string "test.pdf"])
|
||||
(send* (current-ps-setup) (set-margin 0 0) (set-scaling 1.0 1.0))
|
||||
(define dc-output-port (open-output-bytes))
|
||||
(define dc (new pdf-dc% [interactive #f][use-paper-bbox #f][as-eps #f]
|
||||
[output dc-output-port]
|
||||
[width (world:paper-width-default)][height (world:paper-height-default)]))
|
||||
(send dc start-doc "boing")
|
||||
(send dc set-pen "black" 1 'solid)
|
||||
(send dc set-brush "black" 'transparent) ; no fill by default
|
||||
|
||||
|
||||
#;(for ([q (in-vector qs)] #:when (member (quad-name q) renderable-quads))
|
||||
(define p (quad-attr-ref q world:page-key))
|
||||
(gvector-set! page-quad-vector p (cons q (gvector-ref page-quad-vector p null))))
|
||||
|
||||
#;(for/list ([pq (in-gvector page-quad-vector)])
|
||||
(send dc start-page)
|
||||
(map/send render-element (filter-not whitespace/nbsp? elements))
|
||||
(send dc end-page))
|
||||
|
||||
(define (print-status)
|
||||
(send dc draw-text (format "quad pdf test @ ~a" (current-milliseconds)) 0 0))
|
||||
|
||||
(send dc set-font (make-font #:face "Source Code Pro" #:size 10))
|
||||
|
||||
(send dc start-page)
|
||||
(print-status)
|
||||
|
||||
(define default-x 40)
|
||||
(define default-y 40)
|
||||
|
||||
(when qs
|
||||
(for/fold ([page-pos 0]
|
||||
[x-pos default-x]
|
||||
[y-pos default-y])
|
||||
([q (in-vector qs)])
|
||||
(let ([font-attr (hash-ref (quad-attrs q) 'font #f)])
|
||||
(when font-attr
|
||||
(send dc set-font (make-font #:face (string-trim font-attr ".ttf") #:size 10))))
|
||||
(cond
|
||||
[(eq? (quad-dim q) 'page-break)
|
||||
(send dc end-page)
|
||||
(send dc start-page)
|
||||
(print-status)
|
||||
(values page-pos default-x default-y)]
|
||||
[(eq? (quad-dim q) 'line-break)
|
||||
(values page-pos default-x (+ y-pos 12))]
|
||||
[(eq? (quad-dim q) 'column-break)
|
||||
(values page-pos x-pos y-pos)] ; ignore for now
|
||||
[(quad-printable? q)
|
||||
(send dc draw-text (format "~a" (quad-val q)) x-pos y-pos)
|
||||
(values page-pos (+ x-pos (quad-dim q)) y-pos)]
|
||||
[else (values page-pos x-pos y-pos)])))
|
||||
|
||||
(send dc end-page)
|
||||
(send dc end-doc)
|
||||
|
||||
(define result-bytes (get-output-bytes dc-output-port))
|
||||
(display-to-file result-bytes path-string #:exists 'replace #:mode 'binary))
|
||||
|
||||
|
||||
#;(define (render-element q)
|
||||
(cond
|
||||
[(word? q) (render-word q)]
|
||||
[else q]))
|
||||
|
||||
|
||||
(define/caching (make-font/caching font size style weight)
|
||||
(make-font #:face font #:size size #:style style #:weight weight))
|
||||
|
||||
#;(define (render-word w)
|
||||
(define word-font (quad-attr-ref/parameter w world:font-name-key))
|
||||
(define word-size (quad-attr-ref/parameter w world:font-size-key))
|
||||
(define word-style (quad-attr-ref/parameter w world:font-style-key))
|
||||
(define word-weight (quad-attr-ref/parameter w world:font-weight-key))
|
||||
(define word-color (quad-attr-ref/parameter w world:font-color-key))
|
||||
(define word-background (quad-attr-ref/parameter w world:font-background-key))
|
||||
(send dc set-font (make-font/caching word-font word-size word-style word-weight))
|
||||
(send dc set-text-foreground (send the-color-database find-color word-color))
|
||||
(define background-color (send the-color-database find-color word-background))
|
||||
(if background-color ; all invalid color-string values will return #f
|
||||
(send* dc (set-text-mode 'solid) (set-text-background background-color))
|
||||
(send dc set-text-mode 'transparent))
|
||||
|
||||
(define word-text (quad-car w))
|
||||
(send dc draw-text word-text (quad-attr-ref w world:x-position-key)
|
||||
;; we want to align by baseline rather than top of box
|
||||
;; thus, subtract ascent from y to put baseline at the y coordinate
|
||||
(- (quad-attr-ref w world:y-position-key) (quad-attr-ref w world:ascent-key 0)) #t))
|
||||
|
||||
(module+ test
|
||||
(render-pdf))
|
||||
@ -1,30 +0,0 @@
|
||||
#lang quad/dev
|
||||
(require racket/format)
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define (debug-render qs)
|
||||
(define line-counter #f)
|
||||
(define (line-counter-increment!) (set! line-counter (add1 line-counter)))
|
||||
(define (line-counter-reset!) (set! line-counter 1))
|
||||
(line-counter-reset!)
|
||||
(printf " ")
|
||||
(for ([i (in-range 1 71)])
|
||||
(printf (cond
|
||||
[(zero? (modulo i 10)) "|"]
|
||||
[(zero? (modulo i 5)) "'"]
|
||||
[else "·"])))
|
||||
(define (print-line-counter)
|
||||
(printf "\n~a "(~r line-counter #:min-width 2 #:pad-string " " #:base 10)))
|
||||
(print-line-counter)
|
||||
(for ([q (in-vector qs)])
|
||||
(define qd (quad-dim q))
|
||||
(cond
|
||||
[(symbol? qd) ; symbol indicates a break
|
||||
(caseq qd
|
||||
[(line-break) (line-counter-increment!)]
|
||||
[(column-break) (line-counter-reset!) (printf "\n--col--")]
|
||||
[(page-break) (printf "\n\n==page==\n")])
|
||||
(print-line-counter)]
|
||||
[(quad-printable? q) (printf "~a" (quad-val q))]
|
||||
[else (void)]))
|
||||
(printf "\n\n"))
|
||||
Binary file not shown.
@ -1,35 +0,0 @@
|
||||
#lang racket/base
|
||||
|
||||
#|
|
||||
Same semantics as `#lang quad`,
|
||||
but substitutes a Scribble-style text-based reader
|
||||
|#
|
||||
|
||||
(module reader syntax/module-reader
|
||||
quad/main
|
||||
#:read quad-read
|
||||
#:read-syntax quad-read-syntax
|
||||
#:whole-body-readers? #t ;; need this to make at-reader work
|
||||
(require scribble/reader racket/list)
|
||||
(require sugar/debug)
|
||||
|
||||
(define (quad-read p)
|
||||
(syntax->datum (quad-read-syntax (object-name p) p)))
|
||||
|
||||
(define quad-command-char #\@)
|
||||
|
||||
(define (quad-read-syntax path-string p)
|
||||
(define quad-at-reader (make-at-reader
|
||||
#:command-char quad-command-char
|
||||
#:syntax? #t
|
||||
#:inside? #t))
|
||||
(define source-stx (quad-at-reader path-string p))
|
||||
(define source-stx-list (syntax->list source-stx))
|
||||
(define config-line (car source-stx-list))
|
||||
;; we dump all whitespace lines in plain-text mode, as they have no semantic purpose
|
||||
;; the at-reader will kindly separate these all-whitespace lines into their own list elements
|
||||
(define source-stx-no-interline-whitespace
|
||||
(filter-not (λ(stx)
|
||||
(define datum (syntax->datum stx))
|
||||
(and (string? datum) (regexp-match #px"^\\s+$" datum))) (cdr source-stx-list)))
|
||||
(datum->syntax source-stx (cons config-line source-stx-no-interline-whitespace) source-stx)))
|
||||
@ -1,77 +0,0 @@
|
||||
#lang quad/dev
|
||||
(provide (all-defined-out))
|
||||
(require "measure.rkt")
|
||||
|
||||
;; track this k outside of for/fold loop to keep it independent.
|
||||
;; otherwise, every time k is invoked, the loop k will also change.
|
||||
;; (mutated data is not reset by a continuation, but loop vars are)
|
||||
(define last-breakpoint-k raise-overflow-error)
|
||||
|
||||
(define (set-breakpoint-k-here!)
|
||||
(let/cc k (set! last-breakpoint-k k) #f))
|
||||
|
||||
(define (already-breakpoint-type? q type)
|
||||
(eq? (quad-dim q) type))
|
||||
|
||||
(define char-width 6)
|
||||
(define line-width (* 60 char-width)) ; 50 chars, each 6 pts wide
|
||||
(define line-height 12)
|
||||
(define col-height (* 6 line-height)) ; 3 rows, each 12 pts high
|
||||
(define page-width (* 3 line-width)) ; meaning, two columns
|
||||
|
||||
;; posn-page : horiz position of column within page
|
||||
;; posn-col : vert position of line within column
|
||||
;; posn-line : horiz position of char within line
|
||||
(struct posn (page col line) #:transparent)
|
||||
(define (make-posn [page 0] [col 0] [line 0]) (posn page col line))
|
||||
|
||||
(define page-start-position (make-posn))
|
||||
|
||||
(define (fit qs [line-width line-width] [col-height col-height])
|
||||
|
||||
(define (handle-break val [current-posn #f])
|
||||
(caseq val ; test in order of frequency
|
||||
[(line-break) (make-posn (posn-page current-posn) (+ (posn-col current-posn) line-height))]
|
||||
[(column-break) (make-posn (+ (posn-page current-posn) line-width))]
|
||||
[(page-break) page-start-position]
|
||||
[else current-posn]))
|
||||
|
||||
(for/fold ([current-posn page-start-position])
|
||||
([q (in-vector qs)])
|
||||
(unless (quad-dim q) (measure! q))
|
||||
(cond
|
||||
;; shim may contain an imperative break.
|
||||
[($shim? q) (handle-break (quad-dim q) current-posn)]
|
||||
|
||||
;; test for overset (before a new bp-k gets set).
|
||||
;; send break type back through continuation
|
||||
;; we do a combined test to find out the "biggest" break that is needed
|
||||
;; order connotes precedence
|
||||
[(or
|
||||
;; test page-horiz with >= because one column impliedly exists at the start
|
||||
(and (>= (posn-page current-posn) page-width) 'page-break)
|
||||
;; test tp-vert with >= because one column impliedly exists at the start
|
||||
(and (>= (posn-col current-posn) col-height) 'column-break)
|
||||
;; test tp-horiz with > because no characters exist in the line at the start
|
||||
(and (> (posn-line current-posn) line-width) 'line-break)) => last-breakpoint-k]
|
||||
|
||||
;; set a new bp-k, or resume after invoking a bp-k
|
||||
;; bp-k has to be in conditional so it triggers side effect but also forces next branch
|
||||
[(and ($space? q) (set-breakpoint-k-here!))
|
||||
=> ; grabs the value of the condition: the arg passed to breakpoint-k
|
||||
(λ (breakpoint-k-result)
|
||||
(when (already-breakpoint-type? q breakpoint-k-result)
|
||||
;; it means we're caught in an overflow loop, so
|
||||
(raise-overflow-error))
|
||||
;; convert the white, thereby consuming it. todo: don't consume hyphens
|
||||
(quad-dim-set! q breakpoint-k-result)
|
||||
(handle-break breakpoint-k-result current-posn))]
|
||||
|
||||
[else (posn (posn-page current-posn) (posn-col current-posn) (+ (posn-line current-posn) (quad-dim q)))]))
|
||||
qs)
|
||||
|
||||
(module+ test
|
||||
(require "atomize.rkt" "render.rkt")
|
||||
;; todo: preserve space between black quads
|
||||
(define q (quad #f "One morning " (quad #f "and himself")))
|
||||
(time (debug-render (fit (atomize q)))))
|
||||
@ -0,0 +1,3 @@
|
||||
#lang quad/typewriter
|
||||
|
||||
line line line line
|
||||
@ -0,0 +1,47 @@
|
||||
#lang debug br/quicklang
|
||||
(require racket/promise "quad.rkt" "atomize.rkt" "break.rkt")
|
||||
(provide (rename-out [mb #%module-begin]))
|
||||
|
||||
(define optional-break? (λ (q) (and (quad? q) (memv (car (qe q)) '(#\space)))))
|
||||
(struct $slug $quad () #:transparent)
|
||||
(define (slug . xs) ($slug #f xs))
|
||||
(define (lbs xs size [debug #f])
|
||||
(insert-breaks xs size debug
|
||||
#:break-val 'lb
|
||||
#:optional-break-proc optional-break?
|
||||
#:size-proc (λ (q) (let ([val (hash-ref (qa q) 'size (λ ()
|
||||
(if (memv (car (qe q)) '(#\space))
|
||||
(delay (values 0 1 0))
|
||||
(delay (values 1 1 1)))))])
|
||||
(if (promise? val) (force val) (val))))
|
||||
#:finish-segment-proc (λ (pcs) (list ($slug #f pcs)))))
|
||||
|
||||
(define (pbs xs size [debug #f])
|
||||
(insert-breaks xs size debug
|
||||
#:break-val 'pb
|
||||
#:optional-break-proc (λ (x) (eq? x 'lb))
|
||||
#:size-proc (λ (q) (case q
|
||||
[(lb) (values 0 0 0)]
|
||||
[else (values 1 1 1)]))))
|
||||
|
||||
(define (typeset args)
|
||||
(pbs (lbs (atomize (apply quad #f args)) 5) 2))
|
||||
|
||||
(define-syntax-rule (mb lang-line-config-arg . args)
|
||||
(#%module-begin
|
||||
(typeset (list . args))))
|
||||
|
||||
(module reader syntax/module-reader
|
||||
quad/typewriter
|
||||
#:read quad-read
|
||||
#:read-syntax quad-read-syntax
|
||||
#:whole-body-readers? #t ;; need this to make at-reader work
|
||||
(require scribble/reader)
|
||||
|
||||
(define (quad-read p) (syntax->datum (quad-read-syntax (object-name p) p)))
|
||||
|
||||
(define (quad-read-syntax path-string p)
|
||||
(define quad-at-reader (make-at-reader
|
||||
#:syntax? #t
|
||||
#:inside? #t))
|
||||
(quad-at-reader path-string p)))
|
||||
Loading…
Reference in New Issue