aUCBLogo Demos and Tests / music


; These routines were written by David Peacock
; Email - dp@math.com
; 
; IMPORTANT NOTICE:    
; The routines in this "Music" file are written as
; extensions to the Logo programming language. They may
; be freely incorporated into any Logo programs. They must 
; be used in conjunction with the "utilities" procedures.
; Copyright 2004: David Peacock
;
; These routines are free software - you can redistribute and/or
; modify them under the terms of the GNU General Public License
; as published by the Free Software Foundation, either version
; 2 of the License or (at your option) any later version.
; 
; These routines are distributed in the hope that it will be useful
; but WITHOUT ANY WARRANTY; without even the implied warranty
; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
; GNU General Public License for more details. You can obtain a
; copy of the License by writing to:
; Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
; MA 02139, USA.

to music
; Rather than cluttering up the Logo library with my routines, 
; music routines are gathered together in this file.
; To make these routines available to programs, have 'music' as the
; first instruction in the program. (Although the routine is also 
; called by 'utilities' which you probably already use so the extra
; call is redundant.)
;
; Written by David Peacock: davidpeacock@ausdoctors.net
; Setup some musical instrument procedures
equate [clarinet 71 grandpiano 0 honkytonk 3 trumpet 56 violin 40]
; clear display message stack
clear_dispmsg_stack
reset_tally_score
; noteslist 
; close any open midifile
closemidi
; set music directory
make "music_directory "d:/music/midifiles/
bury [[] [music_directory] []]
end



; >>>>>>>>>>>>>>>>>>> MUSIC FUNCTIONS <<<<<<<<<<<<<<<<<<<<<<

to wa_record_save :in_value
make "record%list lput :in_value :record%list
make "record%count :record%count + 1
end

to recorder :xcoord% :ycoord%
make "recordind "false
make "step_ind "false
make "xc1 :xcoord%
make "yc1 :ycoord%
make "defnl "0.25
make "record%count 1
make "save_count  0
make "note_count1 0
make "record%list [[S]]
windowdelete "record%er 
windowcreate "root "record%er [Recorder] :xcoord% :ycoord% 110 110  [ ~
           wa_recorder_controls]
end

to recording
op :recordind
end

to record_note :in_note% :duration% :tied_ind%
; check for tied notes
if not emptyp :musicstack%% [ ~
    if equalp :in_note%  first first :musicstack%% [ ~
          localmake "temp1 last :record%list
          make "record%list  bl :record%list
          make "record%list lput (list :in_note% ~
               (:duration% +  first bf first :musicstack%%) ~
                "true) :record%list
          make "musicstack%% []
          stop]]
make "musicstack%% []
make "record%list lput (list :in_note% :duration% :tied_ind%) :record%list
make "record%count :record%count + 1
end

to wa_recorder_controls 
make "recordind "false
make "step_ind "false
(dispmsg [Note ] -100 200 screencolor ~
      [[Comic Sans MS] -19 0 0 700 0 0 0 0 3 2 1 66]) 
(dispmsg [Count: ] 170 -150 screencolor ~
      [[Comic Sans MS] -19 0 0 700 0 0 0 0 3 2 1 66]) 
(dispmsg :save_count -40 200 screencolor [[Comic Sans MS] -19 0 0 700 0 0 0 0 3 2 1 66])
buttoncreate "record%er [brec] [Record] 35 5 40 10 [wa_recordstart]
buttoncreate "record%er [bplay] [Play] 30 20 50 10 [wa_recordplay]
staticcreate "record%er [record%2] [Recorder] 10 32 80 10
staticupdate "record%2 [Recorder is Stopped]
buttoncreate "record%er [bload] [Load] 10 45 40 10 [wa_recordload -350 250 yellow]
buttoncreate "record%er [bstore] [Store] 60 45 40 10 [wa_recordstore :record%list -100 250 red]
buttoncreate "record%er [btranslate] [Translate] 10 60 40 10 [wa_translate :record%list]
buttoncreate "record%er [bquit] [Quit] 60 60 40 10 [bye bye]
scrollbarcreate "record%er [myscroll] 25 75 50 25 [wa_tempo]
staticcreate "record%er [sttempo] [Tempo] 25 85 45 10
scrollbarset "myscroll 40 120 80
end

to wa_tempo
make "tempo% scrollbarget "myscroll
staticupdate "sttempo (list "Tempo 80-:tempo%)
setfocus [MswLogo Screen]
end

to wa_recorderhelp
end

to wa_recordload :xcoord% :ycoord% :colour1
staticupdate "record%2 [Reading File]
chdir "music
localmake "w1 dialogboxlist starts_withf files  ~
    getanswerword [Please enter first letter of file name] ~ 
       :xcoord% :ycoord% :colour1
if  emptyp first :w1 [messagebox "Error [File not found] stop]
dialogboxmake "root [Choose File] first :w1 last :w1 
localmake "recordfile word "c:\mswlogo\music\ popwork
catch "error [openread :recordfile] 
pushwork error 
if not emptyp popwork  [messagebox "Error [File not found] stop]
ignore error
setread :recordfile 
make "record%list readlist
make "record%count 1
shutfile :recordfile "R
staticupdate "record%2 [File is Read]
setread []
wa_clear_note_count
setfocus [MswLogo Screen]
end

to wa_recordmessage :arg
make "record%count :record%count + 1
setitem :record%count :record%notes :arg
end

to wa_recordnotes
make "record%count :record%count + 1
end

to wa_recordplay
if recording [messagebox "Error [Still recording] stop]
if equalp :record%count 0 [messagebox "Error [Nothing recorded] stop]
make "start_note 1
make "work_list% :record%list 
make "step_ind "false
wa_clear_note_count
(dispmsg [Count: ] 170 -150 yellow ~
      [[Comic Sans MS] -19 0 0 700 0 0 0 0 3 2 1 66]) 
make "recordind "false
delete_recorder
windowcreate "main "playrecord%er [Playing] :xc1 :yc1 120 120  [ ~
         wa_recorderplay_controls]
setfocus [MswLogo Screen]
end

to wa_recorderplay_controls 
buttoncreate "playrecord%er [rpstop] [Return] 3 5 50 10 [wa_recordplay_stop]
buttoncreate "playrecord%er [rpcl] [Cancel] 57 5 50 10 [wa_recorderplay_cancel] 
buttoncreate "playrecord%er [rpAll] [Play ALL] 3 20 50 10 [wa_recorderplay_all]
buttoncreate "playrecord%er [rloop] [Loop] 57 20 50 10 [wa_recorderplay_loop]
buttoncreate "playrecord%er [rfnotes] [From Note_.] 3 35 50 10 [wa_recorderplay_note]
buttoncreate "playrecord%er [rbnotes] [Between Notes_.] 57 35 55 10 [wa_recorderplay_bnotes]
buttoncreate "playrecord%er [rfsection] [From Section_.] 3 50 50 10 [wa_recorderplay_section]
buttoncreate "playrecord%er [rbsect] [Between Sect_.] 57 50 55 10 [wa_recorderplay_snotes]
buttoncreate "playrecord%er [rstep] [Step] 3 65 50 10 [toggle "step_ind]
buttoncreate "playrecord%er [rrpt] [Repeat] 57 65 50 10 [wa_recorderplay_repeat]
buttoncreate "playrecord%er [rquit] [Quit] 3 80 40 10 [bye bye]
end

to wa_recorderplay_cancel
make "cancel$$ "true 
indicator_false 
end

to wa_recorderplay_all
; play entire song
wa_clear_note_count
if emptyp bf :record%list  [messagebox "Error [Nothing to Play] stop]
make "work_list% wa_recordplay_skip 1 :record%list 
wa_recordplay1 :work_list%
end

to wa_recorderplay_bnotes 
local [a1]
make "a1 getanswerlist [Please enter note range] -300 260 red
make "work_list% wa_recordplay_bskip :a1 :record%list
wa_recordplay1 :work_list%
end

to wa_recordplay_bskip :notes% :inlist%
; this routine skips through the input file until the start note
; is reached and keeps the records up to the last note wanted.
; :notes% is a list [startnote endnote]
localmake "counter% 0
op wa_recordplay_bskip2 :notes% :inlist%
end
to wa_recordplay_bskip2 :notes% :inlist%
if emptyp :inlist% [op []]
; skip section headers and don't count rests
if not numberp first first :inlist% [ ~
     op wa_recordplay_bskip2 :notes% bf :inlist%]
if positive first first :inlist%  [ ~
     make "counter% :counter% + 1]
if lessp :counter% first :notes% [ ~
     op wa_recordplay_bskip2 :notes% bf :inlist%]
if greaterp :counter% last :notes% [op []]
op fput first :inlist% wa_recordplay_bskip2 :notes% bf :inlist%
end

to wa_recorderplay_snotes 
if emptyp bf :record%list  [messagebox "Error [Nothing to Play] stop]
local [a1]
make "a1 getanswerlist [Please enter section range] -300 260 red
wa_clear_note_count
make "work_list% wa_recordplay_sskip :a1 :record%list
wa_recordplay1 :work_list%
end

to wa_recordplay_sskip :sections% :inlist%
; this routine skips through the input file until the start section
; is reached and keeps the records up to the last section wanted.
; :sections% is a list [startsection endsection]
localmake "counter% 0
op wa_recordplay_sskip2 :sections% :inlist%
end
to wa_recordplay_sskip2 :sections% :inlist%
if emptyp :inlist% [op []]
; skip section headers
if not numberp first first :inlist% [ ~ 
     make "counter% :counter% + 1]
if lessp :counter% first :sections% [ ~
     op wa_recordplay_sskip2 :sections% bf :inlist%]
if not (lessp :counter% last :sections%) [op []]
op fput first :inlist% wa_recordplay_sskip2 :sections% bf :inlist%
end

to wa_recorderplay_note
if emptyp bf :record%list  [messagebox "Error [Nothing to Play] stop]
indicator_true
while [indicator] [ ~ 
       make "a1 getanswerword [Please enter start note] -300 260 red
       if inrangep :a1 1 1000 [indicator_false]]
wa_clear_note_count
make "note_count1 :a1-1
make "work_list% wa_recordplay_skip :a1 :record%list
wa_recordplay1  :work_list%
end

to wa_recorderplay_section
local [a1]
indicator_true
while [indicator] [ ~ 
       make "a1 getanswerword [Please enter start section] -300 260 red
       if inrangep :a1 1 100 [indicator_false]]
wa_clear_note_count
make "work_list% wa_recordplay_section_skip :a1 :record%list
wa_recordplay1  :work_list%
end

to wa_recorderplay_repeat
; repeat the last song played
if not emptyp :work_list% [ ~
wa_clear_note_count
wa_recordplay1 :work_list%]
end

to wa_recorderplay_loop
; repeat the last song played until cancel
indicator_true
while [indicator] [if not emptyp :work_list% [ ~
      wa_clear_note_count
      wa_recordplay1 :work_list%
      wait 150]]
end

to wa_recordplay_section_skip :start_section :inlist%
; this routine skips through the input file until the start section
; is reached
localmake "counter% 0
op wa_recordplay_section_skip2 :start_section :inlist%
end

to wa_recordplay_section_skip2 :start_section :inlist%
if emptyp :inlist% [op []]
; count section headers
if equalp first first :inlist% "S [ ~ 
     make "counter% :counter% + 1]
if lessp :counter% :start_section [ ~ 
            op wa_recordplay_section_skip2 :start_section bf :inlist%]
op fput first :inlist% wa_recordplay_section_skip2 :start_section bf :inlist%
end

to wa_recordplay_stop 
wa_clear_note_count
windowdelete "playrecord%er
windowcreate "root "record%er [Recorder] :xc1 :yc1 110 110  [wa_recorder_controls]
staticupdate "record%2 [Player is Stopped]
setfocus [MswLogo Screen]
end


to wa_recordplay1 :noteslist 
make "cancel$$ "false
catch "wa_recplay%$% [wa_recordplay2 :tempo% :noteslist]  
setfocus [MswLogo Screen]
end

to wa_recordplay2 :tempo :noteslist
localmake "t1 :tempo
; noteslist has 3 members: note, note.length, tied.indicator
if emptyp :noteslist [throw "wa_recplay%$%]
if :cancel$$ [toggle "cancel$$ throw "wa_recplay%$%]
; change tempo if required.
if equalp first first :noteslist  "T [make "tempo% last first :noteslist ~
                                      make "t1 :tempo%] 
; Skip Section Headers & Tempo markers
if numberp first first :noteslist  [ ~
    wa_playkeys first first :noteslist first bf first :noteslist ~
             last first :noteslist :t1
; not tied notes
    if last first :noteslist [wait round((:t1/5)* (first bf first :noteslist))]] 
wa_recordplay2 :t1 bf :noteslist
end

to wa_recordplay_skip :start_note :inlist%
; this routine skips through the input file until the start note
; is reached
localmake "counter% 0
op wa_recordplay_skip2 :start_note :inlist%
end
to wa_recordplay_skip2 :start_note :inlist%
if emptyp :inlist% [op []]
; skip section headers
if not numberp first first :inlist% [ ~ 
     op wa_recordplay_skip2 :start_note bf :inlist%]
; don't count rests
if positive first first :inlist%  [ ~ 
       make "counter% :counter% + 1]
if lessp :counter% :start_note [op wa_recordplay_skip2 :start_note bf :inlist%]
op fput first :inlist% wa_recordplay_skip2 :start_note bf :inlist%
end

to wa_playkeys :in_note :note_length :tied_note :tempo
  (dispmsg :note_count1 240 -150 screencolor  [[Comic Sans MS] -19 0 0 700 0 0 0 0 3 2 1 66])
   if positive :in_note [ ~
       make "note_count1 :note_count1 + 1]
   localmake "midilist [13 0] 
    dispmsg  :save_note -260 200 screencolor
    make "midilist lput :in_note :midilist
    make "midilist lput 100 :midilist
; adjust velocity by note length
    make "midilist lput (90 + round(:note_length*20)) :midilist
    dispmsg gprop "pitchplist :in_note -260 200 red
    (dispmsg :note_count1 240 -150 green [[Comic Sans MS] -19 0 0 700 0 0 0 0 3 2 1 66])
    make "save_note gprop "pitchplist :in_note
; a note value < 0 indicates a rest
    if greaterp :in_note 0 [midisound  (list :midilist)]
; determine pause between notes and skip if
; tied notes
    ifelse :tied_note [wait round(:note_length * :tempo)
                       MIDIMESSAGE [189 7 0]] ~
                      [wait round((:note_length / 2) * :tempo)]
; check if stepping through notes
    if positive :in_note [if :step_ind [waitkey]]
end

to wa_recordstart 
if recording [messagebox "Error [Already started] stop]
make "recordind "true
; empty stack
make "musicstack%% []
make "record%list [[S]] ; write first section header
make "record%count 1
make "defnl 0.25  ; default note length crotchet
delete_recorder
windowcreate "main "startrecord%er [Recording] :xc1 :yc1 110 115  [ ~
         wa_recorderstart_controls]
setfocus [MswLogo Screen]
(dispmsg [Note ] -100 200 green [[Comic Sans MS] -19 0 0 700 0 0 0 0 3 2 1 66]) 
end

to wa_recorderstart_controls 
buttoncreate "startrecord%er [sstop] [Stop] 35 5 40 10 [wa_recordstop]
buttoncreate "startrecord%er [sdefl] [Def NL] 10 25 40 10 [wa_recorderstart_dnl]
buttoncreate "startrecord%er [srep] [Copy] 10 70 40 10 [wa_recorderstart_repeat]
buttoncreate "startrecord%er [sdn] [Dotted Note] 10 40 40 10 [wa_recorderstart_dn]
buttoncreate "startrecord%er [snl] [Note Length] 60 25 40 10 [wa_recorderstart_notelength]
buttoncreate "startrecord%er [stie] [Tie Notes] 60 40 40 10 [wa_recorderstart_tie]
buttoncreate "startrecord%er [sdt] [Dot-Tie] 10 55 40 10 [wa_recorderstart_dt]
buttoncreate "startrecord%er [srest] [Rest] 60 55 40 10 [wa_recorderstart_rest]
buttoncreate "startrecord%er [sundo] [Undo] 10 85 40 10 [wa_recorderstart_undo] 
buttoncreate "startrecord%er [stempo] [Tempo] 60 85 40 10 [wa_recorderstart_tempo] 
buttoncreate "startrecord%er [ssection] [Section] 60 70 40 10 [wa_recorderstart_section] 
end

to wa_recorderstart_notelength 
; sets a one-off note length
windowdelete "startrecord%er
windowcreate "nl1 "nlrecord%er [Length] :xc1 :yc1 110 110  [wa_recorder_nl_controls]
end

to wa_recorder_nl_controls
buttoncreate "nlrecord%er [nsemib] [SemiBreve] 10 25 40 10 [ ~
  wa_record_nl_adjust 1 wa_record_nl_stop]
buttoncreate "nlrecord%er [nminim] [Minim] 60 25 40 10 [ ~
  wa_record_nl_adjust 0.5 wa_record_nl_stop]
buttoncreate "nlrecord%er [ncrotchet] [Crotchet] 10 38 40 10 [ ~
  wa_record_nl_adjust 0.25 wa_record_nl_stop]
buttoncreate "nlrecord%er [nquaver] [Quaver] 60 38 40 10 [ ~
  wa_record_nl_adjust 0.125 wa_record_nl_stop]
buttoncreate "nlrecord%er [nsquaver] [Semi-Q] 10 51 40 10 [ ~
  wa_record_nl_adjust 0.0625 wa_record_nl_stop]
buttoncreate "nlrecord%er [ndsquaver] [DemiSemi-Q] 60 51 40 10 [ ~
  wa_record_nl_adjust 0.0313 wa_record_nl_stop]
end

to wa_record_nl_adjust :in_note
localmake "temp1 last :record%list
make "record%list bl :record%list
make "record%list lput ~
    (list first :temp1 :in_note last :temp1)   :record%list 
end

to wa_record_nl_stop
windowdelete "nlrecord%er
windowcreate "main "startrecord%er [Recording] :xc1 :yc1 110 110  [ ~
         wa_recorderstart_controls]
end

to wa_recorderstart_dnl 
; sets the default note length
windowdelete "startrecord%er
windowcreate "dnl1 "dnlrecord%er [Length] :xc1 :yc1 110 110  [wa_recorder_dnl_controls]
end

to wa_recorder_dnl_controls
buttoncreate "dnlrecord%er [nsemib] [SemiBreve] 10 25 40 10 [ ~
  make "defnl 1 wa_record_dnl_stop]
buttoncreate "dnlrecord%er [nminim] [Minim] 60 25 40 10 [ ~
  make "defnl 0.5 wa_record_dnl_stop]
buttoncreate "dnlrecord%er [ncrotchet] [Crotchet] 10 38 40 10 [ ~
  make "defnl 0.25 wa_record_dnl_stop]
buttoncreate "dnlrecord%er [nquaver] [Quaver] 60 38 40 10 [ ~
  make "defnl 0.125 wa_record_dnl_stop]
buttoncreate "dnlrecord%er [nsquaver] [Semi-Q] 10 51 40 10 [ ~
  make "defnl 0.0625 wa_record_dnl_stop]
buttoncreate "dnlrecord%er [nssquaver] [DemiSemi-Q] 60 51 40 10 [ ~
  make "defnl 0.0313 wa_record_dnl_stop]
end

to wa_record_dnl_stop
windowdelete "dnlrecord%er
windowcreate "main "startrecord%er [Recording] :xc1 :yc1 110 110  [ ~
         wa_recorderstart_controls]
end

to wa_recorderstart_dt 
; tied notes
wa_recorderstart_dn
wa_recorderstart_tie
end

to wa_recorderstart_dn
; this adjusts a note to be a dotted note ie 1.5x normal length
localmake "temp1 last :record%list
make "record%list bl :record%list
make "record%list lput ~
    (list first :temp1 ((first bf :temp1) * 1.5) last :temp1)   :record%list 
end

to default_note_length
op :defnl
end

to wa_recorderstart_repeat 
localmake "rptlist getanswerlist [Please enter start and end notes] -300 260 red
make "record%list se :record%list wa_recstart_rep1 ~
               (first :rptlist) (last :rptlist) :record%list 1
make "record%count :record%count + ((last :rptlist) - (first :rptlist))
end

to wa_recstart_rep1  :n1 :n2 :in1% :counter
if emptyp :in1% [op []]
if lessp :counter :n1 [op wa_recstart_rep1 :n1 :n2 bf :in1% :counter+1]
if greaterp :counter :n2 [op []]
if positive first first :in1% [ ~
     op combine first :in1% wa_recstart_rep1 :n1 :n2 bf :in1% :counter+1]
op combine first :in1% wa_recstart_rep1 :n1 :n2 bf :in1%  :counter
end

to wa_recorderstart_rest
; sets up the entry for a 'rest'
windowdelete "startrecord%er
windowcreate "note1 "noterecord%er [Length] :xc1 :yc1 110 110  [wa_recorder_note_controls]
end

to wa.recorderstart_section 
make "record%list lput (list "S) :record%list 
end

to wa_recorderstart_tempo
local "a1
indicator_true
while [indicator] [ ~ 
       make "a1 getanswerword [Please enter Tempo] -300 260 yellow
       if inrangep :a1 1 120 [indicator_false]]
make "record%list lput (list "T  :a1) :record%list 
end

to wa_recorderstart_tie 
localmake "temp1 last :record%list
make "record%list bl :record%list
; save tied note on stack
push "musicstack%% :temp1
make "record%list lput (list first :temp1 first bf :temp1 "false) :record%list 
end

to wa_recorderstart_undo
if not emptyp :record%list [ ~
  dispmsg gprop "pitchplist first last :record%list  -260 200 screencolor
  make "record%count :record%count - 1
  make "record%list bl :record%list
  make "save_note first last :record%list
  dispmsg gprop "pitchplist :save_note  -260 200 red]
end

to wa_recorder_note_controls
buttoncreate "noterecord%er [nsemib] [SemiBreve] 10 25 40 10 [ ~
  make "record%list lput [-1 1 true] :record%list wa_record_note_stop]
buttoncreate "noterecord%er [nminim] [Minim] 60 25 40 10 [ ~
  make "record%list lput [-1 0.5 true] :record%list wa_record_note_stop]
buttoncreate "noterecord%er [ncrotchet] [Crotchet] 10 38 40 10 [ ~
  make "record%list lput [-1 0.25 true] :record%list wa_record_note_stop]
buttoncreate "noterecord%er [nquaver] [Quaver] 60 38 40 10 [ ~
  make "record%list lput [-1 0.125 true] :record%list wa_record_note_stop]
buttoncreate "noterecord%er [nsquaver] [Semi-Q] 10 51 40 10 [ ~
  make "record%list lput [-1 0.0625 true] :record%list wa_record_note_stop]
buttoncreate "noterecord%er [ndsquaver] [DemiSemi-Q] 60 51 40 10 [ ~
  make "record%list lput [-1 0.0313 true] :record%list wa_record_note_stop]
end

to wa_record_note_stop
windowdelete "noterecord%er
windowcreate "main "startrecord%er [Recording] :xc1 :yc1 110 110  [ ~
         wa_recorderstart_controls]
end

to wa_recordstop 
if not recording [messagebox "Error [Already stopped] stop]
make "recordind "false
windowdelete "startrecord%er
windowcreate "root "record%er [Recorder] :xc1 :yc1 110 110  [wa_recorder_controls]
staticupdate "record%2 [Recorder is Stopped]
setfocus [MswLogo Screen]
end

to wa_recordstore :inlist :xcoord% :ycoord% :colour1
staticupdate "record%2 [Opening File]
localmake "recordfile word "c:\mswlogo\music\  ~
 getanswerword [Please enter file name] :xcoord% :ycoord% :colour1
ifelse filep :recordfile [~
    ifelse yes [File Exists - Replace?] [if yes [Are you sure?] [ ~
                             openwrite :recordfile  setwrite :recordfile
                             write_to_file :recordfile :record%list
                             staticupdate "record%2 [File is Saved]]] ~
       [if yes [Append to File?]  [openread :recordfile  setread :recordfile
                             localmake "t1 se readlist :record%list
                             setread []
                             close :recordfile
                             openwrite :recordfile  setwrite :recordfile
                             write_to_file :recordfile :t1
                             staticupdate "record%2 [File is Saved]]]] ~ 
    [openwrite :recordfile  setwrite :recordfile
     write_to_file :recordfile :record%list
     staticupdate "record%2 [File is Saved]]
setfocus [MswLogo Screen]
end

to wa_clear_note_count
(dispmsg :note_count1 240 -150 screencolor [[Comic Sans MS] -19 0 0 700 0 0 0 0 3 2 1 66])   
make "note_count1 0
end

to delete_recorder
windowdelete "record%er
end

to note_count
op :record%count
end

to wa_translate :inlist%
show :inlist%
localmake "counter% 0
localmake "section_counter% 0
openfile "c:\mswlogo\music\translist "W
write_to_file "c:\mswlogo\music\translist wa_translate2 :inlist%
end
to wa_translate2 :inlist%
if emptyp :inlist% [op []]
; carry section headers forward
if not numberp first first :inlist% [ ~
    make "section_counter% :section_counter%+1
    op fput (list (word "S :section_counter%)) wa_translate2 bf :inlist%]
; carry rests forward
if negative first first :inlist% [ ~
    op fput (list word gprop "noteplength first bf first :inlist% "Rest) ~
             wa_translate2 bf :inlist%]
make "counter% :counter%+1
if (last first :inlist%) [ ~
  op fput (list :counter%
           word gprop "pitchplist first first :inlist% ~
           gprop "noteplength first bf first :inlist%) ~
           wa_translate2 bf :inlist%]
op fput (list :counter%
         word gprop "pitchplist first first :inlist% ~
         gprop "noteplength first bf first :inlist% "tied) ~
         wa_translate2 bf :inlist%
end

;
; ****** SOUND EFFECTS

; Setup stack to control the opening of the MIDI file and
; open midifile if it is not already open.
to openmidi
   if not namep "midistack%$1 
   [   MidiOpen 0 
      make "midistack%$1 [true]
   ]
end

to closemidi
if namep "midistack%$1 [midiclose ern [midistack%$1]] 
end

; MIDISOUND controls the MIDI sound generator.
; Its input is a list of lists; each sublist has five
; members: [channel instrument pitch volume velocity]
; velocity is how hard you hit the keys
to midisound  :inlist%M 
openmidi
catch "midisound%fjl [midisound%1  :inlist%M] 
end
to midisound%1  :inlist%M 
if emptyp :inlist%M [throw "midisound%fjl]
localmake "midiparms first :inlist%M
localmake "channel first :midiparms
ifelse numberp item 2 :midiparms [~
   localmake "instrument first bf :midiparms] ~
  [localmake "instrument run (list (first bf :midiparms))]
MIDIMESSAGE (LIST (192+:channel) :instrument  0)
MIDIMESSAGE (LIST (176+:channel) 7 last bl :midiparms)
MIDIMESSAGE (LIST (176+:channel) 66 127)
MIDIMESSAGE (LIST (144+:channel) last bl bl :midiparms last :midiparms)
midisound%1 bf :inlist%M
end

to alert
openmidi
MIDIMESSAGE (LIST 192+13 71 0 192+13 71 0)
MIDIMESSAGE (LIST 144+13 75 100)
MIDIMESSAGE (LIST (176+13) 7 100)
WAIT 10
MIDIMESSAGE (LIST 144+13 70 100)
wait 10
MIDIMESSAGE (LIST 144+13 75 100)
WAIT 20
MIDIMESSAGE (LIST 176+13 7 0)
end

to playnote :inlist%M 
; the input list has 3 values: 
; a midilist, notelength & if tied note
; a note value <= 0 indicates a rest
if greaterp item 3 first :inlist%M 0 [ ~
       midisound  (list first :inlist%M)]
; determine pause between notes and skip if
; tied notes
wait first bf :inlist%M
if last :inlist%M [MIDIMESSAGE [189 7 0]] 
end

to noteslist
; set up property lists giving names to notes
; and key signatures
pprop "notesplist "C0 48
pprop "notesplist "C#0 49
pprop "notesplist "D0 50
pprop "notesplist "D#0 51
pprop "notesplist "E0 52
pprop "notesplist "F0 53
pprop "notesplist "F#0 54
pprop "notesplist "G0 55
pprop "notesplist "G#0 56
pprop "notesplist "A0 57
pprop "notesplist "A#0 58
pprop "notesplist "B0 59
pprop "notesplist "C1 60
pprop "notesplist "C#1 61
pprop "notesplist "D1 62
pprop "notesplist "D#1 63
pprop "notesplist "E1 64
pprop "notesplist "F1 65
pprop "notesplist "F#1 66
pprop "notesplist "G1 67
pprop "notesplist "G#1 68
pprop "notesplist "A1 69
pprop "notesplist "A#1 70
pprop "notesplist "B1 71
pprop "notesplist "C2 72
pprop "notesplist "C#2 73
pprop "notesplist "D2 74
pprop "notesplist "D#2 75
pprop "notesplist "E2 76
pprop "notesplist "F2 77
pprop "notesplist "F#2 78
pprop "notesplist "G2 79
pprop "notesplist "G#2 80
pprop "notesplist "A2 81
pprop "notesplist "A#2 82
pprop "notesplist "B2 83
pprop "notesplist "C3 84
pprop "notesplist "C#3 85
pprop "notesplist "D3 86
pprop "notesplist "D#3 87
pprop "notesplist "E3 88
pprop "notesplist "F3 89
pprop "notesplist "F#3 90
pprop "notesplist "G3 91
pprop "notesplist "G#3 92
pprop "notesplist "A3 93
pprop "notesplist "A#3 94
pprop "notesplist "B3 95

pprop "pitchplist 36 "C
pprop "pitchplist 37 "C#
pprop "pitchplist 38 "D
pprop "pitchplist 39 "D#
pprop "pitchplist 40 "E
pprop "pitchplist 41 "F
pprop "pitchplist 42 "F#
pprop "pitchplist 43 "G
pprop "pitchplist 44 "G#
pprop "pitchplist 45 "A
pprop "pitchplist 46 "A#
pprop "pitchplist 47 "B
pprop "pitchplist 48 "C
pprop "pitchplist 49 "C#
pprop "pitchplist 50 "D
pprop "pitchplist 51 "D#
pprop "pitchplist 52 "E
pprop "pitchplist 53 "F
pprop "pitchplist 54 "F#
pprop "pitchplist 55 "G
pprop "pitchplist 56 "G#
pprop "pitchplist 57 "A
pprop "pitchplist 58 "A#
pprop "pitchplist 59 "B
pprop "pitchplist 60 "C
pprop "pitchplist 61 "C#
pprop "pitchplist 62 "D
pprop "pitchplist 63 "D#
pprop "pitchplist 64 "E
pprop "pitchplist 65 "F
pprop "pitchplist 66 "F#
pprop "pitchplist 67 "G
pprop "pitchplist 68 "G#
pprop "pitchplist 69 "A
pprop "pitchplist 70 "A#
pprop "pitchplist 71 "B
pprop "pitchplist 72 "C
pprop "pitchplist 73 "C#
pprop "pitchplist 74 "D
pprop "pitchplist 75 "D#
pprop "pitchplist 76 "E
pprop "pitchplist 77 "F
pprop "pitchplist 78 "F#
pprop "pitchplist 79 "G
pprop "pitchplist 80 "G#
pprop "pitchplist 81 "A
pprop "pitchplist 82 "A#
pprop "pitchplist 83 "B
pprop "pitchplist 84 "C
pprop "pitchplist 85 "C#
pprop "pitchplist 86 "D
pprop "pitchplist 87 "D#
pprop "pitchplist 88 "E
pprop "pitchplist 89 "F
pprop "pitchplist 90 "F#
pprop "pitchplist 91 "G
pprop "pitchplist 92 "G#
pprop "pitchplist 93 "A
pprop "pitchplist 94 "A#
pprop "pitchplist 95 "B
pprop "pitchplist 96 "C
pprop "pitchplist 97 "C#
pprop "pitchplist 98 "D
pprop "pitchplist 99 "D#
pprop "pitchplist 100 "E
pprop "pitchplist 101 "F
pprop "pitchplist 102 "F#
pprop "pitchplist 103 "G
pprop "pitchplist 104 "G#
pprop "pitchplist 105 "A
pprop "pitchplist 106 "A#
pprop "pitchplist 107 "B

pprop "noteplength 1.5 "s_
pprop "noteplength 1 "s 
pprop "noteplength 1.125 "mc_ 
pprop "noteplength 1.0 "s 
pprop "noteplength 0.75 "m_ 
pprop "noteplength 0.5 "m
pprop "noteplength 0.375 "c_
pprop "noteplength 0.25 "c 
pprop "noteplength 0.1875 "q_ 
pprop "noteplength 0.125 "q
pprop "noteplength 0.0938 "sq_
pprop "noteplength 0.0625 "sq
pprop "noteplength 0.0470 "dsq_
pprop "noteplength 0.0313 "dsq

pprop "majorintervals 2 [Major Second]
pprop "majorintervals 4 [Major Third]
pprop "majorintervals 1 [Minor Second]
pprop "majorintervals 3 [Minor Third]
pprop "majorintervals 5 [Perfect Fourth]
pprop "majorintervals 6 [Augmented Fourth]
pprop "majorintervals 7 [Perfect Fifth]
pprop "majorintervals 8 [Augmented Fifth]
pprop "majorintervals 9 [Sixth]
pprop "majorintervals 11 [Seventh]
pprop "majorintervals 10 [Minor Seventh]
pprop "majorintervals 12 [Octave]

pprop "keysignatures "CMajor [[1 #]]
pprop "keysignatures "AMajor [[1 #]]
end

to name_interval :scale :interval
if equalp bf :scale "ajor [op gprop "majorintervals abs :interval]
end

to display_interval :interval :xcoord :ycoord
ifelse greaterp first :interval last :interval [~
  dispmsg name_interval "Major  ((first :interval) - (last :interval)) :xcoord :ycoord green] ~
 [dispmsg name_interval "Major  ((first :interval) - (last :interval)) :xcoord :ycoord red]
end

to flat
; this draws a 'flat' note sign
rt 90
fd 8
rt 135
fd 12
rt 135
fd 20
end

to stave :xcoord%$% :ycoord%$%
; this routine draws a stave of 5 lines
; and outputs the coordinates of the line start position
ht
pu gotoxy :xcoord%$% :ycoord%$% pd
setheading 90
make "scaleplist "F1 pos :linepos
make "scaleplist "E1 pos :linepos

fd 100
pu rt 90
fd 16
rt 90
pd fd 100
make "linepos lput pos :linepos
pu lt 90
fd 16
lt 90 pd
make "linepos lput pos :linepos
fd 100
pu rt 90
fd 16
rt 90
pd fd 100
make "linepos lput pos :linepos
pu lt 90
fd 16
lt 90 pd
make "linepos lput pos :linepos
fd 100
setheading 0
op :linepos
end

to scale_notes :scale_type :startnote##@$
;****************************
; This routine puts out a list containing the MIDI codes for the scale
; starting with :startnote. Startnote is the first note.
; The input can be either the numeric MIDI code or description ie D#1
; For example, if the code for D#1 is entered (),
; the output is [63 65 67 68 70 72 74 75]
localmake "t1 se run (list (word :scale_type "_scale_intervals)) ~
      reverse bl run (list (word :scale_type "_scale_intervals))
ifelse numberp :startnote##@$    [~
  op fput :startnote##@$ lput :startnote##@$ map [sum :startnote##@$ ?] :t1] ~
 [op fput gprop "notesplist :startnote##@$ ~
     lput gprop "notesplist :startnote##@$  ~
     map [sum gprop "notesplist :startnote##@$ ?] :t1]
end

to arpeggio_notes :scale_type :startnote##@$
;****************************
; This routine puts out a list containing the MIDI codes for the arpeggio
; starting with :startnote. Startnote is the first note.
; The input can be either the numeric MIDI code or description ie D#1
; For example, if the code for D#1 is entered (),
; the output is [63 67  70 75 70 67 63]
ifelse numberp :startnote##@$    [~
  op fput :startnote##@$ lput :startnote##@$ ~
        (map [sum :startnote##@$ ?] ~
         run (list (word :scale_type "_arpeggio)))] ~
 [op fput :startnote##@$ fput :startnote##@$ ~
      (map [sum gprop "notesplist :startnote##@$ ?] ~             
      run (list (word :scale_type "_arpeggio)))]
end

to major_scale_intervals
op [2 4 5 7 9 11 12]
end

to minor_scale_intervals
op [2 3 5 7 8 10 12]
end

to major_arpeggio
op [4 7 12 7 4]
end

to minor_arpeggio 
op [2 3 5 7 8 10 12]
end

; draw piano keyboard
to piano_keys
;************
; These routines draw a piano keyboard and set up a coordinate list ("keycoords)
; that holds the coordinate so that the mouse can be used to press the keys.
cs
ht
make "keycoords []
setsc blue
gotoxy -340 0
drawoctave 48
drawoctave 60 
drawoctave 72
make "keycoords lput keypos 30 50 first pos (last pos)+50 84 :keycoords
make "keycoords lput keypos 20 50 (first pos)+20 (last pos)+100 85 :keycoords
leftkey
make "keycoords lput keypos 30 50 first pos (last pos)+50 86 :keycoords
rightkey
; drawoctave
end

to drawoctave :keynum
;********************
make "keycoords lput keypos 30 50 first pos (last pos)+50 :keynum :keycoords
make "keycoords lput keypos 20 50 (first pos)+20 (last pos)+100 :keynum+1 :keycoords
leftkey
make "keycoords lput keypos 30 50 first pos (last pos)+50 :keynum+2 :keycoords
make "keycoords lput keypos 20 50 (first pos)+20 (last pos)+100 :keynum+3 :keycoords
middlekey
make "keycoords lput keypos 30 50 first pos (last pos)+50 :keynum+4 :keycoords
rightkey
make "keycoords lput keypos 30 50 (first pos) (last pos)+50 :keynum+5 :keycoords
make "keycoords lput keypos 20 50 (first pos)+20 (last pos)+100 :keynum+6 :keycoords
leftkey
make "keycoords lput keypos 30 50 first pos (last pos)+50 :keynum+7 :keycoords
make "keycoords lput keypos 20 50 (first pos)+20 (last pos)+100 :keynum+8 :keycoords
middlekey
make "keycoords lput keypos 30 50 first pos (last pos)+50 :keynum+9 :keycoords
make "keycoords lput keypos 20 50 (first pos)+20 (last pos)+100 :keynum+10 :keycoords
middlekey
make "keycoords lput keypos 30 50 first pos (last pos)+50 :keynum+11 :keycoords
make "keycoords lput keypos 20 50 (first pos)+20 (last pos)+100 :keynum+10 :keycoords
rightkey
end

to keypos :xadjust :yadjust  :xcoord% :ycoord%  :keynum
op (list (list :xcoord% :xcoord%+:xadjust) (list :ycoord% (:ycoord%-:yadjust)) :keynum)
end

to leftkey
; setsc blue
setpc red
setheading 0
fd 100
rt 90
fd 20
rt 90
fd 50
lt 90
fd 10
rt 90
fd 50
rt 90
fd 30
setpc white
rt 135
fd 10
setfc white
fill
bk 10
setpc red
setheading 0
rt 90
fd 30
pu
setheading 0
fd 100
bk 100
pd
end

to middlekey
setpc red
setheading 0
fd 50
rt 90
fd 10
lt 90 
fd 50
rt 90
fd 10
rt 90
fd 50
lt 90
fd 10
rt 90
fd 50
rt 90
fd 30

setpc white
rt 135
fd 10
setfc white
fill
bk 10
setpc red
setheading 0
rt 90
fd 30
pu
setheading 0
;fd 100
;bk 100
pd
end

to rightkey
rt 90
fd 30
setheading 0
setpc red
fd 100
lt 90
fd 20
lt 90
fd 50
rt 90
fd 10
lt 90
fd 50
lt 90
fd 30
setpc white
lt 135
fd 10
setfc white
fill
bk 10
setheading 0
; setpc red
; fd 100
; bk 100
setpc white
setheading 0
end

to beep [:inbeep%M [[12 56 70 120 100]]]
midisound :inbeep%M
wait 5
midisound [[12 56 70 0 100]]
soundoff [12]
end

to errbeep
Sounds [400 30  800 30  1200 30]
end

to soundoff :channel% 
if emptyp :channel% [stop]
MIDIMESSAGE (LIST (176 + (first :channel%)) 7 0)
soundoff bf :channel%
end

; SOUNDON turns the volume on for each preset channel.
; Its input is a list of lists; each sublist has two
; members: [channel volume]
to soundon :inparms%
if emptyp :inparms% [stop]
midimessage (list (176 + first first :inparms) 7 last first :inparms) 
soundon bf :inparms%
end


to show_notes
show :record%list
end


to midifile :in_tune
; close any open midifile
closemidi
localmake "t1 gensym 
print sentence [opened sequencer on channel] mci (sentence [open] (word "sequencer! (word :music_directory :in_tune "_mid)) (list "alias  :t1))
print sentence [playing] :in_tune
midiplay  :t1
end

to midiplay :alias
mci (list "seek :alias "to "start)
mci (list "play :alias "wait "notify)
midistop :alias
end

to midistop :alias
mci (list "stop :alias "wait)
mci (list "close :alias "wait)
end 

to midifiles :infile%%
if emptyp :infile%% [closemidi stop]
midifile first :infile%%
wait 300
midifiles bf :infile%%
end

comment [
bury [[music name_interval noteslist playnote piano_keys leftkey middlekey
     rightkey drawoctave keypos scale_notes help_message flat stave ~
     indicator_true indicator_false indicator display_interval wa_recorder_note_controls  wa_recorderstart_repeat ~
     correct%$%  record%count record%list recordfile recordind wa_recorderstart_rest midisound alert beep soundoff soundon errbeep ~
     wa_record_save recorder recording wa_recorder_controls wa_playkeys ~
     wa_recorderhelp wa_recorderload wa_recordersave wa_recordmessage ~ wa_record_note_stop wa_recorderstart_tie  wa_recstart_rep1 ~
      wa_recorder_dnl_controls wa_record_dnl_stop wa_recorderstart_dnl ~
     default_note_length show_notes note_count wa_clear_note_count  ~
     wa_record_nl_adjust wa_record_nl_stop wa_recorder_nl_controls ~
    wa_recorderstart_notelength wa_recordplay_skip wa_recordplay_skip2 ~
     wa_recordnotes wa_recordplay wa_recordplay2 wa_recordstart wa_recorderstart_controls wa_recorderstart_undo wa_recordplay_sskip2 ~
wa_recordplay_sskip wa_recordplay_ssnotes wa_load1 wa_load2 ~
wa_recorderplay_all wa_recorderplay_controls wa_recorderplay_note ~
wa_recorderplay_section wa_recorderstart_dt wa_recorderstart_section  ~
wa_recordplay_stop wa_recordplay1 wa_recorderplay_bnotes  ~
wa_recordplay_bskip  wa_recordplay_bskip2 wa_translate2 wa_translate ~
     wa_recordstop wa_recordstore wa_recordload record_note wa_tempo delete_recorder wa_recorderstart_dn wa_record_note_stop interval_tune ~
wa_recorderplay_repeat wa_recorderplay_snotes wa_recordplay_section_skip ~
wa_recordplay_section_skip2 wa_recorderstart_tempo wa_recorderplay_cancel  ~
major_scale_intervals minor_scale_intervals wa_recorderplay_loop ~
major_arpeggio minor_arpeggio arpeggio_notes scale_notes ~ 
midistop midiplay midifile midifiles] ~
     [midistack%$1 w1 defnl record%count record%list recordind step_ind ~
      record%list xc1 yc1 save_note tempo% start_note counter% notelist
      save_count work_list% start_notes section_counter% note_count1] ~
        [notesplist pitchplist majorintervals keysignatures noteplength]]        
]