happy birthday
parent
86bc94ef6c
commit
46c49c7bbc
@ -0,0 +1,75 @@
|
||||
#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)
|
||||
@ -0,0 +1,357 @@
|
||||
#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))
|
||||
File diff suppressed because one or more lines are too long
@ -0,0 +1,77 @@
|
||||
#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 levels '(none fatal error warning info debug))
|
||||
|
||||
(define/contract (log-level> lev1 lev2)
|
||||
(symbol? symbol? . -> . coerce/boolean?)
|
||||
(member lev1 (cdr (member lev2 levels))))
|
||||
|
||||
(define/contract (log-level>= lev1 lev2)
|
||||
(symbol? symbol? . -> . coerce/boolean?)
|
||||
(member lev1 (member lev2 levels)))
|
||||
|
||||
(define (log-level< lev1 lev2)
|
||||
(log-level> lev2 lev1))
|
||||
|
||||
(define (log-level<= lev1 lev2)
|
||||
(log-level>= lev2 lev1))
|
||||
|
||||
|
||||
(module+ test
|
||||
(check-true (log-level< 'none 'error))
|
||||
(check-true (log-level<= 'none 'none))
|
||||
(check-false (log-level< 'none 'none))
|
||||
(check-true (log-level> 'warning 'error))
|
||||
(check-true (log-level>= 'debug 'debug))
|
||||
(check-false (log-level> 'fatal 'debug)))
|
||||
|
||||
|
||||
(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?"))
|
||||
|
||||
@ -0,0 +1,225 @@
|
||||
#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)
|
||||
|
||||
(define+provide/contract (input->multipages i)
|
||||
(input? . -> . multipages?)
|
||||
(define exploded-input (split-quad i))
|
||||
(map quads->multipage (split-on-page-breaks exploded-input)))
|
||||
|
||||
|
||||
(define/contract (multipage->multicolumns mp)
|
||||
(multipage? . -> . multicolumns?)
|
||||
(map quads->multicolumn (split-on-column-breaks (quad-list mp))))
|
||||
|
||||
|
||||
(define+provide/contract (multicolumn->blocks mc)
|
||||
(multicolumn? . -> . blocks?)
|
||||
;; segfault happens in next line
|
||||
(map quads->block (split-on-block-breaks (quad-list mc))))
|
||||
|
||||
|
||||
(define+provide/contract (merge-adjacent-within q)
|
||||
(quad? . -> . quad?)
|
||||
(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/contract (average-looseness lines)
|
||||
(lines? . -> . flonum?)
|
||||
(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+provide/contract (block->lines b-in)
|
||||
(block? . -> . lines?)
|
||||
(define b (if (ormap string? (quad-list b-in))
|
||||
(quads->block (split-quad b-in))
|
||||
b-in))
|
||||
(define quality (quad-attr-ref/parameter b world:quality-key))
|
||||
(define (wrap-quads qs)
|
||||
(define wrap-proc (if (> quality world:draft-quality) wrap-best wrap-first))
|
||||
(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/contract (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/contract (pages->doc ps)
|
||||
(pages? . -> . doc?)
|
||||
(map quad-attrs (quad-list (first ps)))
|
||||
|
||||
;; 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/contract (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/contract (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 40 world:column-index-key idx) cols))))
|
||||
(reverse cols))))
|
||||
result-pages)
|
||||
|
||||
|
||||
(define/contract (typeset x)
|
||||
(coerce/input? . -> . doc?)
|
||||
(cond
|
||||
[(input? x) (load-text-cache-file)
|
||||
(define multipages (input->multipages x)) ; 170
|
||||
(define pages (append-map typeset multipages)) ; 2370
|
||||
(define doc (typeset pages)) ; 370
|
||||
(update-text-cache-file)
|
||||
doc]
|
||||
[(multipage? x) (define multicolumns (multipage->multicolumns x)) ; 77
|
||||
(define columns (append-map typeset multicolumns)) ; 2420
|
||||
(define pages (typeset columns)) ; 0
|
||||
pages]
|
||||
[(multicolumn? x) (define blocks (multicolumn->blocks x)) ; 85
|
||||
(define lines (append-map typeset blocks)) ; 2422
|
||||
(define columns (typeset lines)) ; 4
|
||||
columns]
|
||||
[(lines? x) (map typeset (lines->columns x))] ; 10
|
||||
[(pages? x) (typeset (pages->doc x))] ; 370
|
||||
[(columns? x) (map typeset (columns->pages x))] ; 1
|
||||
[(block? x) (map typeset (block->lines x))] ; about 2/3 of running time
|
||||
[else x]))
|
||||
|
||||
(define (para ht . xs)
|
||||
(apply box ht `(,(block-break) ,@xs ,(block-break))))
|
||||
|
||||
|
||||
(module+ main
|
||||
(require "render.rkt" racket/class profile)
|
||||
(require "samples.rkt")
|
||||
(activate-logger quad-logger)
|
||||
(parameterize ([world:quality-default world:max-quality]
|
||||
[world:paper-width-default 412]
|
||||
[world:paper-height-default 600])
|
||||
(define to (begin (time (typeset (jude)))))
|
||||
(time (send (new pdf-renderer%) render-to-file to "foo.pdf"))))
|
||||
@ -0,0 +1,67 @@
|
||||
#lang racket/base
|
||||
(require math/flonum racket/draw racket/class racket/contract 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 1000.0)
|
||||
|
||||
(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 (width x) (first x))
|
||||
(define (height x) (second x))
|
||||
(define (descent x) (third x))
|
||||
(define (extra x) (fourth x))
|
||||
|
||||
(define (measure-text-max-size text font [weight 'normal] [style 'normal])
|
||||
(width (measure-max-size text font weight style)))
|
||||
|
||||
(define/contract (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 (fl/ (fl* (fl raw-measure) size) max-size)))
|
||||
|
||||
|
||||
(define (measure-ascent-max-size text font [weight 'normal] [style 'normal])
|
||||
(define result-list (measure-max-size text font weight style))
|
||||
(- (height result-list) (descent result-list)))
|
||||
|
||||
|
||||
(define/contract (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 (fl/ (fl* (fl raw-baseline-distance) size) max-size)))
|
||||
@ -0,0 +1,434 @@
|
||||
#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 value->integer)
|
||||
;(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) (value->integer (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) (value->integer (matrix-proc row-idx (vector-ref col-indices last-stack-idx))))
|
||||
(> (value->integer (matrix-proc (vector-ref stack last-stack-idx) (vector-ref col-indices last-stack-idx)))
|
||||
(value->integer (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 (value->integer (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 value->integer)
|
||||
(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) (value->integer (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 value->integer)
|
||||
;(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 value->integer 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 value->integer)
|
||||
(define idx-of-last-col (sub1 (vector-length col-indices)))
|
||||
(define (smallest-value-entry col idx-of-last-row)
|
||||
(argmin (compose1 value->integer 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)] [value->integer 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 value->integer)])
|
||||
(define odd-column-minima (concave-minima row-indices (vector-odd-elements col-indices) matrix-proc value->integer))
|
||||
(interpolate-proc odd-column-minima row-indices col-indices matrix-proc value->integer))))
|
||||
|
||||
|
||||
#|
|
||||
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 (make-ocm matrix-proc [initial-value 0][value->integer identity])
|
||||
(log-ocm-debug "making new ocm")
|
||||
(define ocm (make-hash))
|
||||
(! ocm 'min-values (vector initial-value))
|
||||
(! ocm 'min-row-indices (vector no-value))
|
||||
(! ocm 'finished 0)
|
||||
(! ocm 'matrix-proc (make-caching-proc matrix-proc))
|
||||
(! ocm 'value->integer value->integer) ; for converting matrix values to an integer
|
||||
(! ocm 'base 0)
|
||||
(! ocm 'tentative 0)
|
||||
ocm)
|
||||
|
||||
|
||||
;; Return min { Matrix(i,j) | i < j }.
|
||||
(define (min-value ocm j)
|
||||
(if (< (: ocm 'finished) j)
|
||||
(begin (advance! ocm) (min-value ocm j))
|
||||
(vector-ref (: ocm 'min-values) j)))
|
||||
|
||||
;; Return argmin { Matrix(i,j) | i < j }.
|
||||
(define (min-index ocm j)
|
||||
(if (< (: ocm 'finished) j)
|
||||
(begin (advance! ocm) (min-index ocm j))
|
||||
(vector-ref (: ocm 'min-row-indices) j)))
|
||||
|
||||
;; Finish another value,index pair.
|
||||
(define (advance! ocm)
|
||||
(define next (add1 (: ocm 'finished)))
|
||||
(log-ocm-debug "advance! ocm to next = ~a" (add1 (: ocm '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 'tentative))
|
||||
(log-ocm-debug "advance: first case because next (~a) > tentative (~a)" next (: ocm 'tentative))
|
||||
(define rows (list->vector (range (: ocm 'base) next)))
|
||||
(! ocm 'tentative (+ (: ocm 'finished) (vector-length rows)))
|
||||
(define cols (list->vector (range next (add1 (: ocm 'tentative)))))
|
||||
(define minima (concave-minima rows cols (: ocm 'matrix-proc) (: ocm 'value->integer)))
|
||||
(for ([col (in-vector cols)])
|
||||
(cond
|
||||
[(>= col (vector-length (: ocm 'min-values)))
|
||||
(! ocm 'min-values (vector-append-item (: ocm 'min-values) (: (: minima col) 'value)))
|
||||
(! ocm 'min-row-indices (vector-append-item (: ocm 'min-row-indices) (: (: minima col) 'row-idx)))]
|
||||
[(< ((: ocm 'value->integer) (: (: minima col) 'value)) ((: ocm 'value->integer) (vector-ref (: ocm 'min-values) col)))
|
||||
(! ocm 'min-values (vector-set (: ocm 'min-values) col (: (: minima col) 'value)))
|
||||
(! ocm 'min-row-indices (vector-set (: ocm 'min-row-indices) col (: (: minima col) 'row-idx)))]))
|
||||
(! ocm '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 'matrix-proc) (sub1 next) next))
|
||||
(cond
|
||||
[(< ((: ocm 'value->integer) diag) ((: ocm 'value->integer) (vector-ref (: ocm 'min-values) next)))
|
||||
(log-ocm-debug "advance: second case because column minimum is on the diagonal")
|
||||
(! ocm 'min-values (vector-set (: ocm 'min-values) next diag))
|
||||
(! ocm 'min-row-indices (vector-set (: ocm 'min-row-indices) next (sub1 next)))
|
||||
(! ocm 'base (sub1 next))
|
||||
(! ocm 'tentative next)
|
||||
(! ocm '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 'value->integer) ((: ocm 'matrix-proc) (sub1 next) (: ocm 'tentative)))
|
||||
((: ocm 'value->integer) (vector-ref (: ocm 'min-values) (: ocm 'tentative))))
|
||||
(log-ocm-debug "advance: third case because row i-1 does not suppply a column minimum")
|
||||
(! ocm '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 'base (sub1 next))
|
||||
(! ocm 'tentative next)
|
||||
(! ocm 'finished next)])]))
|
||||
|
||||
(define (print ocm)
|
||||
(displayln (: ocm 'min-values))
|
||||
(displayln (: ocm '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
|
||||
|
||||
)
|
||||
@ -0,0 +1,192 @@
|
||||
"""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.
@ -0,0 +1,66 @@
|
||||
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)}'''
|
||||
@ -0,0 +1,241 @@
|
||||
#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/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)))) (void))
|
||||
(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) (string? 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/contract (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/contract (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/contract (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-syntax-rule (gather-common-attrs qs-in)
|
||||
(let ([qs qs-in])
|
||||
(and (quad-attrs (car qs))
|
||||
(let ([attr-missing (gensym)])
|
||||
(let loop ([qs (cdr qs)]
|
||||
[common-attrs (for/list ([kv-pair (in-hash-pairs (quad-attrs (car qs)))]
|
||||
#:unless (member (car kv-pair) cannot-be-common-attrs))
|
||||
kv-pair)])
|
||||
(cond
|
||||
[(empty? common-attrs) #f]
|
||||
[(empty? qs) (flatten common-attrs)]
|
||||
[else (define reference-quad (car qs))
|
||||
(loop (cdr qs)
|
||||
(filter (λ(ca) (let ([v (quad-attr-ref reference-quad (car ca) attr-missing)])
|
||||
(equal? v (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/contract (id [attrs #f] . 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/contract (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/contract (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 #f q))
|
||||
(define coerce/input? (make-coercion-contract input))
|
||||
|
||||
@ -0,0 +1,105 @@
|
||||
#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/contract 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))))
|
||||
File diff suppressed because one or more lines are too long
@ -0,0 +1,194 @@
|
||||
#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" "main.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 first-fit-proc))
|
||||
|
||||
;; 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 best-fit-proc))
|
||||
|
||||
(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-fast (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) <)))
|
||||
@ -0,0 +1,79 @@
|
||||
#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)
|
||||
@ -0,0 +1,93 @@
|
||||
#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 #f "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)))) #f)
|
||||
(check-equal? (gather-common-attrs (list (box '(width bar)) (box '(width bar)) (box '(width bar)))) #f)
|
||||
|
||||
(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 #f (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))
|
||||
|
||||
(let ([world:minimum-last-line-chars 0])
|
||||
(check-equal? (map (compose1 quad-list last quad-list) (make-pieces (split-quad (block #f "Foo-dog and " (box) " mas\u00adsachu.")))) '(("o") ("g") ("d") () ("s") ("."))))
|
||||
|
||||
(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 #f) 'foo 'zam) (box '(foo zam)))
|
||||
(check-equal? (quad-attr-set* (box #f) '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 #f) '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 #f) 'zim) (box))
|
||||
|
||||
(check-true (quad-ends-with? (box #f "foo") "foo"))
|
||||
(check-false (quad-ends-with? (box #f "foo") "food"))
|
||||
(check-false (quad-ends-with? (box #f (box #f "foo")) "food"))
|
||||
(check-true (quad-ends-with? (box #f (box #f "foo")) "foo"))
|
||||
(check-true (quad-ends-with? (box #f (box #f "foo")) "o"))
|
||||
(check-true (quad-ends-with? (box #f (box #f (box #f (box #f (box #f "foo-"))))) "-"))
|
||||
|
||||
(check-equal? (quad-append (box #f "foo") "bar") (box #f "foo" "bar"))
|
||||
(check-equal? (quad-append (box #f "foo") (box #f "bar")) (box #f "foo" (box #f "bar")))
|
||||
|
||||
(check-equal? (quad-last-char (box #f (box #f "foo") "food")) "d")
|
||||
(check-equal? (quad-last-char (box #f (box #f "foo") "")) "o")
|
||||
(check-equal? (quad-last-char (box #f "foo")) "o")
|
||||
(check-false (quad-last-char (box)))
|
||||
|
||||
(check-equal? (quad-first-char (box #f (box #f "foo") "bar")) "f")
|
||||
(check-equal? (quad-first-char (box #f "" (box #f "foo") "bar")) "f")
|
||||
(check-equal? (quad-first-char (box #f "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) (box '(width 100)))) "")
|
||||
|
||||
|
||||
(check-false (whitespace? (~a #\u00A0)))
|
||||
(check-true (whitespace/nbsp? (~a #\u00A0)))
|
||||
(check-true (whitespace/nbsp? (word #f (~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))
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,16 @@
|
||||
#lang racket/base
|
||||
|
||||
;; todo next
|
||||
;; segfault on command line?
|
||||
;; adaptive linebreak using fu-formula
|
||||
;; pagination: vertical measuring
|
||||
;; use smawk penalty system for pagination too?
|
||||
;; 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
|
||||
;; fractional point sizes (asked Flatt)
|
||||
;; how are opentype features handled (asked Flatt)
|
||||
Loading…
Reference in New Issue