! Copyright (C) 2026 Serre
! See https://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs calendar classes.tuple
combinators generalizations kernel lexer math math.parser
multiline namespaces peg.ebnf present sequences 5line.midi
sequences.generalizations shuffle sorting strings threads ;
IN: 5line

! == Abstraction of a Musical Note
! * TODO: Rests, triplets, arbitrary midi (drums) 
TUPLE: note
   name accidental octave
   length dot? tied? ;
! Tied only applies if the *previous* note is tied to this one:
!     X. Y. Z == XYZ played as one tie

SYMBOLS: sharp flat natural rest
   whole-note half-note quarter-note eigth-note 
   sixteenth-note thirtysecond-note ;

CONSTANT: shorthand-table H{
   { "w" whole-note } { "h" half-note }
   { "q" quarter-note } { "e" eigth-note }
   { "s" sixteenth-note } { "t" thirtysecond-note }
   { "#" sharp } { "b" flat } { "n" natural } }

CONSTANT: note-names { "C" "D" "E" "F" "G" "A" "B" }

! * Note Syntax:
! Ex. "Cb3-h.t" -- C3 Flat, Tied & Dotted Half Note.
EBNF: parse-note [=[
   name = [A-G]
      => [[ '{ _ } >string ]]
   accidental = { "#" | "b" | "n" }
      => [[ shorthand-table at ]]
   octave = [0-9]
      => [[ 48 - ]]
   length = { "w" | "h" | "q" | "e" | "s" | "t" }
      => [[ shorthand-table at ]]
   note = name accidental? octave "-" length "."? "t"?
      => [[ 3 swap remove-nth \ note prefix unpack-tuple ]]
]=]
SYNTAX: N: scan-token parse-note suffix ;

: unparse-note ( note -- string )
   { [ name>> ]
     [ accidental>> shorthand-table value-at ]
     [ octave>> number>string ] [ drop "-" ]
     [ length>> shorthand-table value-at ]
     [ dot?>> "." f ? ] [ tied?>> "t" f ? ]
   } cleave 7 narray sift concat ;
   
M: note present unparse-note ;

TUPLE: pattern
   spots key-sig tempo time-sig ;

! (Kind of obnoxiously picky)
DEFER: (unravel-pattern-ebnf)
EBNF: parse-pattern [=[
   whitespace = " "+
   head = [0-9]+'/'[0-9]+ " @ " [0-9]+ " bpm in key " [-0-9]+
      => [[ [ string>number ] map sift ]]
   note = (whitespace?)~ ( [0-9a-zA-Z] | [#.-] )+ (" "?)~
      => [[ >string parse-note ]]
   spot = ('\n'?)~ (note)+ '\n'~
    end = "|| FIN"
   pattern = head '\n'~ (spot)+ end~
      => [[ (unravel-pattern-ebnf) ]] 
   ]=]
: (unravel-pattern-ebnf) ( ast -- pattern )
   pattern new
   over second >>spots
   over first 
      [ first ] [ second ] bi 2array >>time-sig
   over first third >>tempo
   over first fourth >>key-sig
   nip ;
SYNTAX: PATTERN: 
   "!" parse-multiline-string parse-pattern suffix! ;

! == Working with Pitches

DEFER: (n.fix)
:: raise-note ( note by -- note' )
! Sometimes doesn't work inside of map/each calls?
   note dup name>>
   note-names [ index by + 7 /mod (n.fix) ] keep nth
      [ [ + ] curry change-octave ] [ >>name ]
   bi-curry* compose call ;
   
: (n.fix) ( d.octave d.note -- d.octave d.note )
   dup 0 < [ [ 1 - ] [ 7 + ] bi* ] when ;
   
: n+ ( note -- note )  1 raise-note ;
: n- ( note -- note ) -1 raise-note ;

! ** Should be key-aware for Naturals, double sharps etc.
: n-sharpen ( note -- note )
   [ flat = f sharp ? ] change-accidental ;
: n-flatten ( note -- note )
   [ sharp = f flat ? ] change-accidental ;

CONSTANT: key-sharps
   { "F" "C" "E" "D" "A" "E" }
CONSTANT: key-flats
   { "B" "E" "A" "D" "G" "C" }

: keysig-notes ( int -- notes accidentals )
   7 /mod [ -6 * ] dip +
   { { [ dup 0 > ] [ key-sharps resize-array sharp ] }
     { [ dup 0 < ] [ -1 * key-flats resize-array flat ] }
     [ drop f natural ]
   } cond ;

! == Converting Pitch to MIDI Message Values

: note-numbers ( -- alist )
   note-names { 0 2 4 5 7 9 11 } zip ;
   
: note>natural-midi ( note -- midi-key )
   [ name>> note-numbers at ] [ octave>> ] bi 12 * + ;
   
: do-accidentals ( int accidental -- int )
   { { sharp [ 1 + ] } { flat [ 1 - ] } [ drop ] } case ;
   
: note>baseline-midi ( note -- midi-key )
   [ note>natural-midi ] keep accidental>> do-accidentals ;

: note>delta-keysig ( note keysig -- int )
   [ name>> ] [ keysig-notes ] bi* -rot member?
   [ 0 swap do-accidentals ] [ drop 0 ] if ;

: note>midi ( note keysig -- midi-key )
   over accidental>> natural = [ drop note>natural-midi ] [
      [ note>delta-keysig ] [ drop note>baseline-midi ] 2bi +
   ] if ;
   
! == Working with Note Duration
   
! * A spot is a sequence of notes. The length of a spot is the
! length of it's shortest(?) note. Notes on a single pattern can
! only start after the end of the last spot.

CONSTANT: time-values H{
   { whole-note 1 } { half-note 1/2 }
   { quarter-note 1/4 } { eigth-note 1/8 }
   { sixteenth-note 1/16 } { thirtysecond-note 1/32 }
   }

: time-val ( note -- fraction )
   [ length>> time-values at ] [ dot?>> ] bi [ 3/2 * ] when ;
   
: spot-val ( spot -- fraction ) [ time-val ] map sort first ;

:: time-val>duration ( val tempo time-sig -- dt )
! That took embarassingly long to figure out TT_TT
         time-sig second :> beat-multiplier
   val beat-multiplier * :> effective-beat
      effective-beat tempo / 60 * seconds ;

: note-duration ( note tempo time-sig -- dt ) 
   [ time-val ] 2dip time-val>duration ;
: spot-duration ( spot tempo time-sig -- fraction )
   [ spot-val ] 2dip time-val>duration ;

! == Playing Notes & Spots.
! * Ties are a nightmare if we insist on using "dial-for" on
! them, so instead we break up starting and ending a tone into
! distinct actions that ties can skip over.
INITIALIZED-SYMBOL: active-ties 
   [ { } ] ! List of MIDI Note/Channel pairs

: already-tied? ( midi-key ch. -- ? )
   2array active-ties get-global member? ;

:: (play-note) ( midi-key tied? dt ch. -- )
   midi-key ch.
      2dup already-tied?
         [ 2array [ remove ] curry 
           active-ties swap change-global ] 
         [ dial-on ] 
      if
   tied?
         [ midi-key ch. 2array [ suffix ] curry  
           active-ties swap change-global ] 
         [ midi-key dt ch. dial-off-in ]
      if ;

: play-note ( note keysig tempo timesig ch. -- )
   [ [ 2drop [ note>midi ] [ drop tied?>> ] 2bi ]
     [ nipd note-duration ] 4 nbi
   ] dip (play-note) ;

: play-spot ( spot keysig tempo timesig ch. -- )
   [ [ play-note ] 4 ncurry each ]
       [ drop nipd spot-duration ] 5 nbi 
   sleep ;
   
: play-pattern ( pattern ch. -- )
   [ { [ spots>> ] [  key-sig>> ] [ tempo>> ] [ time-sig>> ] }
   cleave ] dip [ play-spot ] 4 ncurry each ;

! Multiple patterns in series we call a sequence
: play-sequence ( patterns ch. prog -- )
   dupd swap chg-prog [ play-pattern ] curry each ;

! Multiple sequences in parallel we call a track
: play-track ( sequences/ch.s/progs -- )
      [ first3 [ play-sequence stop ] 3curry "5Line Track" 
         spawn drop ] 
   each ;
   
!  Stopping playback in the middle of a tie can break later
! attempts at playback if not cleaned up afterwards
: clear-note-state ( -- )
   midi-panic { } active-ties set-global ;

! == Dealing with Measures
: measure-threshold ( timesig -- time-val )
   ! "3/4" and "6/8" are different meters, but the measures
   ! hold the same time-value of notes.
   [ first ] [ second ] bi / ;
   
: measure-sum ( measure -- time-val ) [ spot-val ] map sum ;

: append-to-measures ( measures spot time-sig -- measures )
   dupdd [ ?last [ { } ] unless* ] [ ] [ measure-threshold ]
   tri* pick measure-sum <=
! When a measure's full, start a new one
     [ 1array nip suffix ]
! Otherwise add the spot to this one.
     [ suffix [ [ empty? ] [ but-last ] 1unless ] dip suffix ] 
   if ;

: measures ( spots timesig -- measures )
   [ append-to-measures ] curry [ { } ] dip reduce ;
! * Repeating this reduce could be expensive for long patterns.
! Maybe some kind of caching is in order?