@ -1,5 +1,5 @@
#lang debug racket/base
#lang debug racket/base
( require ( for-syntax racket/base ) txexpr racket/runtime-path racket/ string racket/promise racket/match racket/list
( require ( for-syntax racket/base ) txexpr racket/runtime-path racket/ path racket/ string racket/promise racket/match racket/list
pitfall quad sugar/debug pollen/tag racket/unsafe/ops )
pitfall quad sugar/debug pollen/tag racket/unsafe/ops )
( provide ( except-out ( all-from-out racket/base ) #%module-begin )
( provide ( except-out ( all-from-out racket/base ) #%module-begin )
( rename-out [ mb #%module-begin ] )
( rename-out [ mb #%module-begin ] )
@ -17,7 +17,8 @@
( define mdash " — " )
( define mdash " — " )
( define-tag-function ( p attrs exprs )
( define-tag-function ( p attrs exprs )
( qexpr ( append ` ( ( keep-first " 2 " ) ( keep-last " 3 " ) ( font-family " charter " ) ( display , ( symbol->string ( gensym ) ) ) ) attrs ) exprs ) )
;; no font-family so that it adopts whatever the surrounding family is
( qexpr ( append ` ( ( keep-first " 2 " ) ( keep-last " 3 " ) ( display , ( symbol->string ( gensym ) ) ) ) attrs ) exprs ) )
( define-tag-function ( hr attrs exprs )
( define-tag-function ( hr attrs exprs )
hrbr )
hrbr )
@ -123,18 +124,7 @@
( λ ( q doc ) ( draw-debug q doc " #99f " " #ccf " ) )
( λ ( q doc ) ( draw-debug q doc " #99f " " #ccf " ) )
void ) ) )
void ) ) )
( define-runtime-path charter " fonts/charter.ttf " )
( define default-font-face " fonts/default.ttf " )
( define-runtime-path charter-bold " fonts/charter-bold.ttf " )
( define-runtime-path charter-italic " fonts/charter-italic.ttf " )
( define-runtime-path fira " fonts/fira.ttf " )
( define-runtime-path fira-bold " fonts/fira-bold.ttf " )
( define-runtime-path fira-italic " fonts/fira.ttf " )
( define-runtime-path fira-light " fonts/fira-light.ttf " )
( define-runtime-path fira-light-bold " fonts/fira-light-bold.ttf " )
( define-runtime-path fira-light-italic " fonts/fira-light-italic.ttf " )
( define-runtime-path fira-mono " fonts/fira-mono.ttf " )
( define default-font-face charter )
( define default-font-family " charter " )
( define default-font-family " charter " )
( define default-font-size 12 )
( define default-font-size 12 )
@ -145,37 +135,6 @@
( struct-copy
( struct-copy
quad q:string
quad q:string
[ attrs ( let ( [ attrs ( quad-attrs q ) ] )
[ attrs ( let ( [ attrs ( quad-attrs q ) ] )
;; attrs hashes are shared between many quads.
;; so the first update will change every reference to the shared hash
;; hence why we ignore if val is already a path
;; but this op should ideally happen earlier
( unless ( quad-ref q font-path-key )
( hash-set! attrs font-path-key
( match ( string-downcase
( string-replace ( or ( quad-ref q ' font-family ) default-font-family ) " " " - " ) )
[ " charter " ( if ( quad-ref q ' font-bold )
( if ( quad-ref q ' font-italic )
( error ' no-charter-bold-italic )
charter-bold )
( if ( quad-ref q ' font-italic )
charter-italic
charter ) ) ]
[ " fira " ( if ( quad-ref q ' font-bold )
( if ( quad-ref q ' font-italic )
( error ' no-fira-bold-italic )
fira-bold )
( if ( quad-ref q ' font-italic )
fira-italic
fira ) ) ]
[ " fira-light " ( if ( quad-ref q ' font-bold )
( if ( quad-ref q ' font-italic )
( error ' no-fira-light-italic )
fira-light-bold )
( if ( quad-ref q ' font-italic )
fira-light-italic
fira-light ) ) ]
[ " fira-mono " fira-mono ]
[ _ default-font-face ] ) ) )
( hash-ref! attrs ' fontsize default-font-size )
( hash-ref! attrs ' fontsize default-font-size )
attrs ) ]
attrs ) ]
[ elems ( quad-elems q ) ]
[ elems ( quad-elems q ) ]
@ -376,7 +335,7 @@
( scale doc ( if zoom-mode? 3 1 ) ( if zoom-mode? 3 1 ) ) )
( scale doc ( if zoom-mode? 3 1 ) ( if zoom-mode? 3 1 ) ) )
#:draw-end ( λ ( q doc )
#:draw-end ( λ ( q doc )
( font-size doc 10 )
( font-size doc 10 )
( font doc charter )
( font doc default-font-face )
( fill-color doc " black " )
( fill-color doc " black " )
( text doc ( format " ~a · ~a at ~a " ( hash-ref ( quad-attrs q ) ' page-number )
( text doc ( format " ~a · ~a at ~a " ( hash-ref ( quad-attrs q ) ' page-number )
( hash-ref ( quad-attrs q ) ' doc-title )
( hash-ref ( quad-attrs q ) ' doc-title )
@ -458,6 +417,11 @@
' ( ( 1 1 ) ( 2 2 2 ) ( 3 ) ( 4 ) ( 5 5 ) ( 6 6 ) ( 7 ) ( 8 ) ( 9 ) ) ) )
' ( ( 1 1 ) ( 2 2 2 ) ( 3 ) ( 4 ) ( 5 5 ) ( 6 6 ) ( 7 ) ( 8 ) ( 9 ) ) ) )
( define ( page-wrap xs vertical-height path )
( define ( page-wrap xs vertical-height path )
;; on timing of `insert-blocks`:
;; can't do it before because it depends on where pages are broken.
;; could do it after, but it would require going back inside each page quad
;; which seems overly interdependent, because `insert-blocks` is used to determine break locations.
;; `page-wrap` should emit quads that are complete.
( wrap xs vertical-height
( wrap xs vertical-height
#:soft-break ( λ ( q ) #true )
#:soft-break ( λ ( q ) #true )
#:no-break ( λ ( q ) ( quad-ref q ' no-pbr ) )
#:no-break ( λ ( q ) ( quad-ref q ' no-pbr ) )
@ -483,19 +447,77 @@
[ #false line-group ]
[ #false line-group ]
[ _ ( list ( block-wrap line-group ) ) ] ) ) ) )
[ _ ( list ( block-wrap line-group ) ) ] ) ) ) )
( define ( run xs path )
( define font-paths ( make-hash ) )
( define ( setup-font-path-table! base-path )
;; populate `font-paths` table with font paths
;; search "fonts" subdirectory in project for other subdirectories
;; which are presumed to contain fonts.
;; and link them to their family names & styles.
;; this allows a flexible mapping from internal to external names, like @font-face
;; note that all the semantics are derived from the file system
;; not any metadata fields within the font.
;; this is faster and easier, because you can just muck with the directory and filenames
;; to change the font mapping.
;; though it also creates the potential for mischief,
;; if a font is named something that doesn't reflect its visual reality.
;; but we are not the font police.
( define-values ( dir path _ ) ( split-path base-path ) )
( define fonts-dir ( build-path dir " fonts " ) )
( for* ( [ font-family-subdir ( in-directory fonts-dir ) ]
#:when ( directory-exists? font-family-subdir )
[ font-path ( in-directory font-family-subdir ) ]
#:when ( path-has-extension? font-path #" ttf " ) )
( match-define ( list font-path-string family-name )
( map ( λ ( x ) ( path->string ( find-relative-path fonts-dir x ) ) ) ( list font-path font-family-subdir ) ) )
( define key
( cons family-name
( match ( string-downcase font-path-string )
[ ( and ( regexp " bold " ) ( regexp " italic " ) ) ' bi ]
[ ( regexp " bold " ) ' b ]
[ ( regexp " italic " ) ' i ]
[ _ ' r ] ) ) )
;; only set value if there's not one there already.
;; this means that we only use the first eligible font we find.
( hash-ref! font-paths key font-path ) ) )
( define ( font-attrs->path font-family bold italic )
;; find the font-path corresponding to a certain family name and style.
( define key ( cons font-family
( cond
[ ( and bold italic ) ' bi ]
[ bold ' b ]
[ italic ' i ]
[ else ' r ] ) ) )
( define regular-key ( cons font-family ' r ) )
( cond
[ ( hash-ref font-paths key #false ) ]
;; if there isn't one, try the regular style.
[ ( hash-ref font-paths regular-key #false ) ]
;; If there isn't one, use the default.
[ else default-font-face ] ) )
( define ( resolve-font-path attrs )
( define this-font-family ( hash-ref! attrs ' font-family default-font-family ) )
( define this-bold ( hash-ref! attrs ' font-bold #false ) )
( define this-italic ( hash-ref! attrs ' font-italic #false ) )
( hash-set! attrs ' font-path ( font-attrs->path this-font-family this-bold this-italic ) ) )
( define ( run xs pdf-path )
( define pdf ( time-name make-pdf ( make-pdf #:compress #t
( define pdf ( time-name make-pdf ( make-pdf #:compress #t
#:auto-first-page #f
#:auto-first-page #f
#:output-path path
#:output-path p df-p ath
#:width ( if zoom-mode? 350 612 )
#:width ( if zoom-mode? 350 612 )
#:height ( if zoom-mode? 400 792 ) ) ) )
#:height ( if zoom-mode? 400 792 ) ) ) )
( define line-width ( - ( pdf-width pdf ) ( * 2 side-margin ) ) )
( define line-width ( - ( pdf-width pdf ) ( * 2 side-margin ) ) )
( define vertical-height ( - ( pdf-height pdf ) top-margin bottom-margin ) )
( define vertical-height ( - ( pdf-height pdf ) top-margin bottom-margin ) )
( let* ( [ x ( time-name atomize ( atomize ( qexpr->quad xs ) ) ) ]
( setup-font-path-table! pdf-path )
( let* ( [ x ( time-name parse-qexpr ( qexpr->quad xs ) ) ]
[ x ( time-name atomize ( atomize x #:attrs-proc resolve-font-path ) ) ]
[ x ( time-name ->string-quad ( map ( λ ( x ) ( ->string-quad pdf x ) ) x ) ) ]
[ x ( time-name ->string-quad ( map ( λ ( x ) ( ->string-quad pdf x ) ) x ) ) ]
[ x ( time-name line-wrap ( line-wrap x line-width ) ) ]
[ x ( time-name line-wrap ( line-wrap x line-width ) ) ]
[ x ( time-name apply-keeps ( apply-keeps x ) ) ]
[ x ( time-name apply-keeps ( apply-keeps x ) ) ]
[ x ( time-name page-wrap ( page-wrap x vertical-height path ) ) ]
[ x ( time-name page-wrap ( page-wrap x vertical-height p df-p ath) ) ]
[ x ( time-name position ( position ( struct-copy quad q:doc [ elems x ] ) ) ) ] )
[ x ( time-name position ( position ( struct-copy quad q:doc [ elems x ] ) ) ) ] )
( time-name draw ( draw x pdf ) ) ) )
( time-name draw ( draw x pdf ) ) ) )