239 lines
10 KiB
Text
239 lines
10 KiB
Text
### Autoarg macro
|
|
define-operator "--" 890 'right' : syntax-rules
|
|
`(@l -- @r) [atom l] : dirty `[new $NamedParameterPair$ @{".quote" [formOf l]} @r]
|
|
|
|
### Macro for identity match
|
|
define-macro Just : begin
|
|
local m : syntax-rules
|
|
`[Just @x] : dirty x
|
|
|
|
set coinit.initFn : lambda [m] : begin
|
|
set m.toPattern : lambda [form env w] : match form
|
|
`[Just @x] : object
|
|
whether : lambda [t] : ex `(@t === @x) env
|
|
assign : lambda [t locallyQ] : ex `[begin] env
|
|
|
|
return m
|
|
|
|
define-macro params : syntax-rules
|
|
`[params @_pairs @body] : begin
|
|
local ta : env.newt
|
|
local tb : env.newt
|
|
local t : env.newt
|
|
local ps `[begin
|
|
[local @ta : {}.slice.call arguments 0]
|
|
[local @tb {}]
|
|
[for [local @t 0] (@t < @ta.length) [inc @t] : if [not : @ta.(@t) <@ $NamedParameterPair$] : @tb.push @ta.(@t)]
|
|
]
|
|
local aps `[begin]
|
|
local dps `[begin]
|
|
local j 0
|
|
foreach [pf : items-of : formOf _pairs] : begin
|
|
local name
|
|
if [atom pf] : then
|
|
ps.push `[local @pf : fallback @pf (@tb).(@{".quote" j})]
|
|
set name pf
|
|
: else
|
|
ps.push `[local @(pf.0) : fallback @(pf.0) (@tb).(@{".quote" j}) @(pf.1)]
|
|
set name pf.0
|
|
aps.push `[if (@t && @t <@ $NamedParameterPair$ && @t.left == @{".quote" name}) [set @name @t.right]]
|
|
if pf.2 : dps.push `[local @(pf.2) @name]
|
|
inc j
|
|
ps.push `[foreach [@t : items-of @ta] @aps]
|
|
ps.push dps
|
|
ps.push : formOf body
|
|
return : dirty ps
|
|
|
|
### Necessary macros
|
|
# A glyph construction is a function which "modifies" a glyph.
|
|
define-macro glyph-proc : syntax-rules
|
|
`[glyph-proc @::steps] : dirty `[lambda [] [begin \\
|
|
local currentGlyph this
|
|
begin @::[steps.map formOf]
|
|
return nothing
|
|
]]
|
|
|
|
define-macro composite-proc : syntax-rules
|
|
`[composite-proc @::steps] : dirty `[lambda [] [begin \\
|
|
local currentGlyph this
|
|
begin @::[steps.map : lambda [x j] : if j `[include @[formOf x]] `[include @[formOf x] true true]]
|
|
return nothing
|
|
]]
|
|
|
|
# Remap Glyph's methods to macros in order to simplify writing
|
|
define-macro set-width : syntax-rules
|
|
`[set-width @::args] {'.syntactic-closure' `[currentGlyph.setWidth @::args] env}
|
|
define-macro include : syntax-rules
|
|
`[include @::args] {'.syntactic-closure' `[currentGlyph.include @::args] env}
|
|
define-macro set-mark-anchor : syntax-rules
|
|
`[set-mark-anchor @::args] {'.syntactic-closure' `[currentGlyph.setMarkAnchor @::args] env}
|
|
define-macro set-base-anchor : syntax-rules
|
|
`[set-base-anchor @::args] {'.syntactic-closure' `[currentGlyph.setBaseAnchor @::args] env}
|
|
define-macro eject-contour : syntax-rules
|
|
`[eject-contour @::args] {'.syntactic-closure' `[currentGlyph.ejectTagged @::args] env}
|
|
|
|
###### Canvas-based mechanism
|
|
define-macro new-glyph : syntax-rules
|
|
`[new-glyph @body] : begin
|
|
dirty `[$createAndSaveGlyphImpl$ null null @[formOf body]]
|
|
|
|
define-macro create-glyph : syntax-rules
|
|
`[create-glyph @body] : begin
|
|
if [not externEnv.$nWFGlyphs$] : set externEnv.$nWFGlyphs$ 0
|
|
inc externEnv.$nWFGlyphs$
|
|
local f0 : '.' + [[env.macros.get 'input-path']].1 + '.'
|
|
local tcn {".quote" (".WF" + f0 + externEnv.$nWFGlyphs$)}
|
|
dirty `[$createAndSaveGlyphImpl$ @tcn null @[formOf body]]
|
|
`[create-glyph @name @body] : begin
|
|
dirty `[$createAndSaveGlyphImpl$ @[formOf name] null @[formOf body]]
|
|
`[create-glyph @name @code @body] : begin
|
|
dirty `[$createAndSaveGlyphImpl$ @[formOf name] @[formOf code] @[formOf body]]
|
|
|
|
define-macro create-aliased-glyph : syntax-rules
|
|
`[create-aliased-glyph @name] : begin
|
|
dirty `[create-aliased-glyph @[formOf name] null]
|
|
`[create-aliased-glyph @name @code] : begin
|
|
dirty `[$createAndSaveGlyphImpl$ @[formOf name] @[formOf code] [lambda : begin
|
|
[this.include currentGlyph true true]
|
|
[this.cloneRankFromGlyph currentGlyph] ]]
|
|
|
|
define-macro create-forked-glyph : syntax-rules
|
|
`[create-forked-glyph @body] : begin
|
|
if [not externEnv.$nWFGlyphs$] : set externEnv.$nWFGlyphs$ 0
|
|
inc externEnv.$nWFGlyphs$
|
|
local f0 : '.' + [[env.macros.get 'input-path']].1 + '.'
|
|
local tcn {".quote" (".WF" + f0 + externEnv.$nWFGlyphs$)}
|
|
dirty `[create-forked-glyph @tcn null @[formOf body]]
|
|
`[create-forked-glyph @name @body] : begin
|
|
dirty `[create-forked-glyph @[formOf name] null @[formOf body]]
|
|
`[create-forked-glyph @name @code @body] : begin
|
|
dirty `[$createAndSaveGlyphImpl$ @[formOf name] @[formOf code] [lambda : begin
|
|
[this.include currentGlyph true true]
|
|
[this.cloneRankFromGlyph currentGlyph]
|
|
[this.include @[formOf body]] ]]
|
|
|
|
###### Glyph modules and Glyph blocks
|
|
|
|
define-macro glyph-module : syntax-rules
|
|
`[glyph-module] : dirty `[begin \\
|
|
define $GlyphBlocks$ {}
|
|
export : define [apply] : begin
|
|
foreach [block : items-of $GlyphBlocks$] : block this
|
|
]
|
|
|
|
define-macro run-glyph-module : syntax-rules
|
|
`[run-glyph-module @path] : dirty `[[import @path].apply.call $$Capture$$]
|
|
|
|
define-macro glyph-block-import : syntax-rules
|
|
`[glyph-block-import @_blockName] : begin
|
|
|
|
define allExports : object
|
|
Common-Derivatives `[select-variant orthographic-italic refer-glyph query-glyph
|
|
alias turned HDual HCombine VDual VCombine derive-glyphs derive-composites
|
|
link-reduced-variant alias-reduced-variant glyph-is-needed HalfAdvance TurnMarks
|
|
create-two-part-glyph]
|
|
|
|
CommonShapes `[Rect SquareAt Ring RingAt DotAt RingStroke RingStrokeAt DotStrokeAt
|
|
CircleRing CircleRingAt CircleDotAt OShape OShapeOutline OShapeFlatTB OBarLeftShape
|
|
OBarRightShape LeftwardTopSerif LeftwardBottomSerif RightwardTopSerif
|
|
RightwardBottomSerif CenterTopSerif CenterTopSerifAsymmetric CenterBottomSerif
|
|
CenterBottomSerifAsymmetric DownwardRightSerif UpwardRightSerif DownwardLeftSerif
|
|
UpwardLeftSerif NeedSlab NeedNotItalic HBar HBarTop HBarBottom HOverlayBar VBar
|
|
VBarLeft VBarRight VerticalHook LeftHook FlatSlashShape hookstart hookend FlipAround
|
|
ScaleAround Realign ForceUpright DiagCor NameUni PointingTo WithTransform clear-anchors
|
|
OBarLeftToothlessShape OBarLeftRoundedShape OBarRightToothlessShape
|
|
OBarRightRoundedShape AsRadical ExtLineCenter ExtLineLhs DiagCorDs HCrossBar VERY-FAR
|
|
MaskAbove MaskBelow MaskLeft MaskRight]
|
|
|
|
define vartiableFilter : if externEnv.$glyphBlockVariableUsage$
|
|
lambda [x] externEnv.$glyphBlockVariableUsage$.(x)
|
|
lambda [x] true
|
|
|
|
local blockName : formOf _blockName
|
|
if allExports.(blockName)
|
|
dirty `[define [object @::[allExports.(blockName).filter vartiableFilter]] : $Capture$.(@({".quote" blockName})).resolve]
|
|
dirty `[$Capture$.(@({".quote" blockName})).resolve]
|
|
|
|
`[glyph-block-import @_blockName @_variables] : begin
|
|
local blockName {'.quote' [formOf _blockName]}
|
|
local variables : formOf _variables
|
|
dirty `[define [object @::variables] : $Capture$.(@blockName).resolve]
|
|
|
|
define-macro glyph-block-export : syntax-rules
|
|
`[glyph-block-export @::obj] : begin
|
|
dirty `[$ExportCapture$ : lambda [] : object @::[obj.map formOf]]
|
|
|
|
define-macro for-width-kinds : syntax-rules
|
|
`[for-width-kinds @_desired @::_body] : dirty `[ do \\
|
|
define WidthKinds {
|
|
{ 0 '.NWID' $Capture$.metrics.Width 1 }
|
|
{ 1 '.WWID' $Capture$.metrics.WideWidth0 2 }
|
|
}
|
|
foreach {FMosaicWide MosaicNameSuffix MosaicWidth MosaicWidthScalar} [items-of WidthKinds] : do
|
|
define MosaicDesiredWidth @[formOf _desired]
|
|
define MosaicMiddle : MosaicWidth / 2
|
|
define MosaicUnitWidth : MosaicWidth / MosaicWidthScalar
|
|
define [MangleUnicode unicode _desiredOverride]
|
|
if (MosaicWidth == (_desiredOverride || MosaicDesiredWidth)) unicode nothing
|
|
define [MangleName name] : name + MosaicNameSuffix
|
|
begin @::[_body.map formOf]
|
|
]
|
|
|
|
define-macro end-glyph-block : syntax-rules
|
|
`[end-glyph-block] : begin
|
|
set externEnv.$glyphBlockVariableUsage$ null
|
|
dirty `[begin nothing]
|
|
|
|
### Do not nest
|
|
define-macro glyph-block : syntax-rules
|
|
`[glyph-block @_blockName @_body] : begin
|
|
local blockName {'.quote' [formOf _blockName]}
|
|
local body : formOf _body
|
|
|
|
# Trace every variable name in the body
|
|
local variableSet : Object.create null
|
|
define [traceBody form] : piecewise
|
|
(form <@ Array) : form.forEach traceBody
|
|
([typeof form] === "string") : set variableSet.(form) true
|
|
|
|
traceBody body
|
|
traceBody `[$NamedParameterPair$ $donothing$ $createAndSaveGlyphImpl$ $assignUnicodeImpl$]
|
|
|
|
set externEnv.$glyphBlockVariableUsage$ variableSet
|
|
|
|
define captureImports `[metrics $NamedParameterPair$ $donothing$ para recursive
|
|
recursiveCodes glyphStore $createAndSaveGlyphImpl$
|
|
spirofns booleFns MarkSet AS_BASE ALSO_METRICS pickHash
|
|
buildGlyphs tagged DivFrame fontMetrics $assignUnicodeImpl$]
|
|
|
|
define metricImports `[UPM HalfUPM Width SB CAP XH Descender Contrast SymbolMid ParenTop
|
|
ParenBot OperTop OperBot TackTop TackBot PlusTop PlusBot PictTop PictBot BgOpTop BgOpBot
|
|
Italify Upright Scale Translate ApparentTranslate Rotate GlobalTransform TanSlope
|
|
HVContrast Upward Downward Rightward Leftward UpwardT DownwardT LeftwardT RightwardT
|
|
O OX OXHook Hook AHook SHook RHook JHook FHook HookX Smooth SmallSmooth Stroke DotSize
|
|
PeriodSize HBarPos OverlayPos LongJut Jut VJut Accent AccentX AccentBaseOffset
|
|
AccentStackOffset CThin CThinB SLAB TailAdjX TailAdjY IBalance IBalance2 JBalance
|
|
JBalance2 TBalance TBalance2 RBalance RBalance2 FBalance OneBalance WideWidth0
|
|
WideWidth1 WideWidth2 WideWidth3 WideWidth4 Ess EssQuestion HalfStroke RightSB
|
|
Middle DotRadius PeriodRadius SideJut SmoothA SmoothB SmallSmoothA SmallSmoothB
|
|
CorrectionOMidX CorrectionOMidS AdviceStroke AdviceStroke2 MVertStroke OverlayStroke
|
|
OperatorStroke GeometryStroke ShoulderFine _SuperXY adviceSSmooth
|
|
adviceGlottalStopSmooth shoulderMidSlope StrokeWidthBlend SmoothAOf SmoothBOf
|
|
SmoothAdjust MidJutSide MidJutCenter compositeBaseAnchors YSmoothMidR YSmoothMidL]
|
|
define spiroFnImports `[g4 g2 corner flat curl close end straight widths
|
|
disable-contrast heading unimportant important alsoThru alsoThruThem bezControls
|
|
quadControls archv arcvh complexThru dispiro spiro-outline]
|
|
define booleFnImports `[union intersection difference]
|
|
|
|
dirty `[$GlyphBlocks$.push : lambda [$Capture_Ext$] : begin \\
|
|
$Capture_Ext$.$defineGlyphBlockImpl$ $Capture_Ext$ @blockName
|
|
function [$Capture$ $ExportCapture$] : begin
|
|
define [object @::[captureImports.filter : lambda [x] variableSet.(x)]] $Capture$
|
|
define [object @::[metricImports.filter : lambda [x] variableSet.(x)]] $Capture$.metrics
|
|
define [object @::[spiroFnImports.filter : lambda [x] variableSet.(x)]] $Capture$.spirofns
|
|
define [object @::[booleFnImports.filter : lambda [x] variableSet.(x)]] $Capture$.booleFns
|
|
|
|
* @body
|
|
|
|
end-glyph-block
|
|
]
|