$$include '../../meta/macros.ptl'

import [mix linreg clamp fallback] from "@iosevka/util"
import [Transform] from "@iosevka/geometry/transform"

glyph-module

glyph-block Symbol-Pictograph-Musical : begin
	glyph-block-import CommonShapes
	glyph-block-import Common-Derivatives

	define fine : AdviceStroke 6
	define noteSize : Width * 0.4 + fine / 2
	define noteCompress 0.8
	define commonNoteBottom : PictBot + noteCompress / 2 * noteSize
	define [BandShape z1 z2 l r h] : begin
		local slope : (z2.y - z1.y) / (z2.x - z1.x)
		local yl : z1.y + (l - z1.x) * slope
		local yr : z1.y + (r - z1.x) * slope
		return : spiro-outline
			corner l (yl + 0)
			corner r (yr + 0)
			corner r (yr + h)
			corner l (yl + h)
	define [MusicalNoteAt size x y] : glyph-proc
		include : Ring (noteCompress / 2 * (-size)) (noteCompress / 2 * (+size)) (-size) 0
		include : Ungizmo
		include : new Transform 1 0 0.15 1 0 0
		include : Translate x y
		include : Regizmo

	create-glyph 'crotchet' 0x2669 : union
		MusicalNoteAt noteSize (Middle + noteSize / 6 + [HSwToV : 0.5 * fine]) commonNoteBottom
		VBar.m (Middle + noteSize / 6) commonNoteBottom PictTop fine

	create-glyph 'quaver' 0x266A : glyph-proc
		local x3 : mix Middle RightSB 0.35
		local y3 : mix PictBot PictTop 0.25
		local y2 : mix y3 PictTop 0.25
		include : union
			MusicalNoteAt noteSize Middle commonNoteBottom
			VBar.r Middle commonNoteBottom PictTop fine
			dispiro
				widths.rhs fine
				g4.down.start Middle PictTop
				g4.down.mid RightSB y2
				g4 x3 y3

	do "Beamed Notes"
		local x1 : Middle - noteSize / 6
		local x2 : x1 + noteSize * 7 / 6
		local deltaY : noteCompress * noteSize / 2
		local lb1 : PictBot + noteCompress / 2 * noteSize
		local bandWidth : noteSize * noteCompress * 0.75

		create-glyph 'beamQuaver' 0x266B : difference
			union
				MusicalNoteAt noteSize x1 commonNoteBottom
				VBar.r x1 commonNoteBottom (PictTop - deltaY) fine
				MusicalNoteAt noteSize x2 (commonNoteBottom + deltaY)
				VBar.r x2 (commonNoteBottom + deltaY) PictTop fine
				BandShape
					object [x x1] [y : PictTop - deltaY]
					object [x x2] [y PictTop]
					x1 - [HSwToV fine]
					x2 + 0
					0 - bandWidth
			BandShape
				object [x x1] [y : PictTop - deltaY]
				object [x x2] [y PictTop]
				x1 - [HSwToV fine]
				x2 + 0
				0 + bandWidth

		create-glyph 'beamSemiQuaver' 0x266C : union [refer-glyph 'beamQuaver']
			BandShape
				object [x x1] [y : PictTop - deltaY - 1.5 * bandWidth]
				object [x x2] [y : PictTop - 1.5 * bandWidth]
				x1 - [HSwToV fine]
				x2 + 0
				0 - bandWidth

	do "Accidentals"
		glyph-block-import Symbol-Arrow-Shared : ArrowShape
		local nsTop PictTop
		local nsBot PictBot
		local fine  : AdviceStroke 3.5
		local fine2 : AdviceStroke 4
		local lAcc : SB - fine * 0
		local rAcc : RightSB + fine * 0
		local hsp : ((rAcc - lAcc) - [HSwToV : 2 * fine]) * 0.3
		local skew 0.2

		local krNat 0.5
		local lSharp : lAcc + hsp * krNat
		local rSharp : rAcc - hsp * krNat
		local lFlat : mix SB RightSB 0.07
		local rFlat : mix RightSB SB 0.07
		local lNat : lAcc + hsp * krNat
		local rNat : rAcc - hsp * krNat

		local halfVFine : HSwToV : 0.5 * fine
		local xUpSharp   : rSharp - halfVFine
		local xDownSharp : rSharp - halfVFine
		local xUpFlat    : lFlat  + halfVFine
		local xDownFlat  : lFlat  + halfVFine
		local xUpNat     : lNat   + halfVFine
		local xDownNat   : rNat   - halfVFine
		local arrowWidth : (RightSB - SB) * 0.35
		local arrowSpace : Math.max (0.9 * arrowWidth) (ParenTop - PictTop)
		local arrowTop   : nsTop + arrowSpace
		local arrowBot   : nsBot - arrowSpace

		create-glyph 'sharpTone' 0x266F : glyph-proc
			include : dispiro
				widths.center
				flat lAcc ([mix nsTop nsBot 0.3] - (Middle - lAcc) * skew) [heading Rightward]
				curl rAcc ([mix nsTop nsBot 0.3] - (Middle - rAcc) * skew) [heading Rightward]
			include : dispiro
				widths.center
				flat lAcc ([mix nsTop nsBot 0.7] - (Middle - lAcc) * skew) [heading Rightward]
				curl rAcc ([mix nsTop nsBot 0.7] - (Middle - rAcc) * skew) [heading Rightward]
			include : VBar.l lSharp (nsBot - (Middle - lSharp) * skew) (nsTop - (Middle - lSharp) * skew) fine
			include : VBar.r rSharp (nsBot - (Middle - rSharp) * skew) (nsTop - (Middle - rSharp) * skew) fine

		define [FlatToneShape _l _r _sw] : glyph-proc
			local yTerminal : mix nsBot nsTop 0.55
			local curly  0.65
			local curly2 1.1
			local curly3 0.3
			local l : fallback _l lFlat
			local r : fallback _r rFlat
			local sw : fallback _sw fine

			define [archShapeT offset] : list
				[if offset g4 corner] l (nsBot - offset) [widths.lhs (sw + offset)]
				alsoThru 0.5 curly3
				g4.up.mid (r - O + offset) ([mix nsBot yTerminal curly] + (r - l) * skew - TanSlope * SmoothAdjust)
				arcvh
				arch.lhs.centerAt.rtl.t [mix l r 0.5] ([mix nsBot yTerminal curly2] + (r - l) * skew / 2 + offset) (sw -- (sw + offset))
				[if offset g4 corner] l (yTerminal + offset)

			include : difference
				union
					VBar.l l nsBot nsTop sw
					dispiro [archShapeT 1]
				difference
					spiro-outline
						corner l     (nsBot - UPM)
						archShapeT    0
						corner l     (yTerminal + 1)
						corner l      nsTop
						corner Width  nsTop
						corner Width (nsBot - UPM)
					spiro-outline
						corner  0                yTerminal
						corner  0                nsTop
						corner (l + [HSwToV sw]) nsTop
						corner (l + [HSwToV sw]) yTerminal
				spiro-outline
					corner  l        (nsBot - UPM)
					corner  l         nsTop
					corner (l - UPM)  nsTop
					corner (l - UPM) (nsBot - UPM)

		create-glyph 'flatTone' 0x266D : glyph-proc
			include : FlatToneShape

		create-glyph 'naturalTone' 0x266E : glyph-proc
			local k : 0.25 - (QuarterStroke / (nsTop - nsBot))

			local barLeft  : VBar.l lNat [mix nsBot nsTop k] nsTop fine
			local barRight : VBar.r rNat nsBot [mix nsBot nsTop (1 - k)] fine
			local diagLow : dispiro
				widths.lhs fine
				flat   lNat  [mix nsBot nsTop k]
				curl   rNat ([mix nsBot nsTop k] + (rNat - lNat) * skew)
			local belowDiagLow : spiro-outline
				corner lNat  [mix nsBot nsTop k]
				corner rNat ([mix nsBot nsTop k] + (rNat - lNat) * skew)
				corner rNat nsBot
				corner lNat nsBot
			local diagHigh : dispiro
				widths.lhs fine
				flat   rNat  [mix nsBot nsTop (1 - k)]
				curl   lNat ([mix nsBot nsTop (1 - k)] - (rNat - lNat) * skew)
			local aboveDiagHigh : spiro-outline
				corner rNat  [mix nsBot nsTop (1 - k)]
				corner lNat ([mix nsBot nsTop (1 - k)] - (rNat - lNat) * skew)
				corner lNat nsTop
				corner rNat nsTop
			local outsideBars : difference
				spiro-outline
					corner (lNat - UPM) (nsBot - UPM)
					corner (lNat - UPM) (nsTop + UPM)
					corner (rNat + UPM) (nsTop + UPM)
					corner (rNat + UPM) (nsBot - UPM)
				spiro-outline
					corner lNat nsBot
					corner lNat nsTop
					corner rNat nsTop
					corner rNat nsBot

			include : union
				difference barLeft belowDiagLow
				difference barRight aboveDiagHigh
				difference diagLow barLeft barRight outsideBars
				difference diagHigh barLeft barRight outsideBars

		create-glyph 'dblSharpTone' 0x1D12A : glyph-proc
			local w : rAcc - lAcc
			local cx : mix lAcc rAcc 0.5
			local cy : [mix [mix nsBot nsTop 0.5] CAP 0.3] + AccentStackOffset / 2
			local t : cy + w / 2 - fine * 0
			local b : cy - w / 2 + fine * 0
			local cofine : Math.max (w / 9) : Math.min (w / 3) : VSwToH (w * (2 / 3) - [HSwToV Stroke])
			local p 0.5
			local size : w * (5 / 12)
			include : union
				difference
					spiro-outline
						corner lAcc t
						corner rAcc t
						corner rAcc b
						corner lAcc b
					union
						VBar.m cx b t [VSwToH cofine]
						HBar.m lAcc rAcc cy cofine
				spiro-outline
					corner (cx - size)    (cy + size)
					g4      cx            (cy + size * p)
					corner (cx + size)    (cy + size)
					g4     (cx + size * p) cy
					corner (cx + size)    (cy - size)
					g4      cx            (cy - size * p)
					corner (cx - size)    (cy - size)
					g4     (cx - size * p) cy
					close

		create-glyph 'dblFlatTone' 0x1D12B : glyph-proc
			local sw : AdviceStroke 4
			include : union
				FlatToneShape lAcc (Middle + sw / 3) sw
				FlatToneShape (Middle - sw / 3) rAcc sw

		create-glyph 'qtrSharpTone' 0x1D132 : glyph-proc
			include : dispiro
				widths.center
				flat lAcc ([mix nsTop nsBot 0.3] - (Middle - lAcc) * skew) [heading Rightward]
				curl rAcc ([mix nsTop nsBot 0.3] - (Middle - rAcc) * skew) [heading Rightward]
			include : dispiro
				widths.center
				flat lAcc ([mix nsTop nsBot 0.7] - (Middle - lAcc) * skew) [heading Rightward]
				curl rAcc ([mix nsTop nsBot 0.7] - (Middle - rAcc) * skew) [heading Rightward]
			include : VBar.m Middle nsBot nsTop fine

		create-glyph 'qtrFlatTone' 0x1D133 : glyph-proc
			include : FlatToneShape
			include : FlipAround Middle SymbolMid (-1) (+1)

		create-glyph 'flatToneUp' 0x1D12C : composite-proc
			refer-glyph 'flatTone' AS_BASE ALSO_METRICS
			ArrowShape xUpFlat SymbolMid xUpFlat arrowTop arrowWidth halfVFine
		create-glyph 'flatToneDown' 0x1D12D : composite-proc
			refer-glyph 'flatTone' AS_BASE ALSO_METRICS
			ArrowShape xDownFlat SymbolMid xDownFlat arrowBot arrowWidth halfVFine
		create-glyph 'naturalToneUp' 0x1D12E : composite-proc
			refer-glyph 'naturalTone' AS_BASE ALSO_METRICS
			ArrowShape xUpNat SymbolMid xUpNat arrowTop arrowWidth halfVFine
		create-glyph 'naturalToneDown' 0x1D12F : composite-proc
			refer-glyph 'naturalTone' AS_BASE ALSO_METRICS
			ArrowShape xDownNat SymbolMid xDownNat arrowBot arrowWidth halfVFine
		create-glyph 'sharpToneUp' 0x1D130 : composite-proc
			refer-glyph 'sharpTone' AS_BASE ALSO_METRICS
			ArrowShape xUpSharp SymbolMid xUpSharp arrowTop arrowWidth halfVFine
		create-glyph 'sharpToneDown' 0x1D131 : composite-proc
			refer-glyph 'sharpTone' AS_BASE ALSO_METRICS
			ArrowShape xDownSharp SymbolMid xDownSharp arrowBot arrowWidth halfVFine
