[q-lang-cvs] q-midi/src midi_player.q,NONE,1.1 midi_player.tcl,NONE,1.1 Makefile.am,1.1.1.1,1.2 play
Brought to you by:
agraef
Menu
▾
▴
[q-lang-cvs] q-midi/src midi_player.q,NONE,1.1 midi_player.tcl,NONE,1.1 Makefile.am,1.1.1.1,1.2 player.q,1.1.1.1,NONE player.tcl,1.1.1.1,NONE
|
From: <ag...@us...> - 2004-01-05 19:59:48
|
Update of /cvsroot/q-lang/q-midi/src
In directory sc8-pr-cvs1:/tmp/cvs-serv29297/src
Modified Files:
Makefile.am
Added Files:
midi_player.q midi_player.tcl
Removed Files:
player.q player.tcl
Log Message:
renamed player -> midi_player, updated docs
--- NEW FILE: midi_player.q ---
#!/usr/bin/q --
#! -c main ARGS
/* midi_player.q: simple MIDI player/recorder for the Q-Midi interface */
/* This file is part of the Q programming system.
The Q programming system is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
The Q programming system is 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 should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
/* TODO: ********************************************************************
- add configuration dialog for changing input/ouput devices, PPQN/BPM
settings and MIDI Thru setting
**************************************************************************/
import midi, mididev, tk;
/* This script extends the capabilities of the Q-Midi interface with some
useful functions for playing back and recording multi-track sequences,
represented as time-ordered lists of (TRACK,TIME,MSG) triples. It also
serves as an example to illustrate how to write sequencer-like applications
in Q. The main function is `midi_player' which implements a Tk-based GUI
for playing back and recording MIDI sequences. Convenience functions for
loading and saving MIDI files and basic sequence editing are also
provided. */
/* midi_player SEQ: This is the main function. It provides a Tk interface with
the usual push button controls (play, stop, record, etc.), a progress
meter, and options to load and save sequences in MIDI files. SEQ is the
input sequence and may be denoted may either by a (possibly empty) list or
the name of a MIDI file which is loaded using `midi_load' (see below). The
result is a sequence consisting of all tracks recorded during the player
session -- without the input sequence. If desired, you can mix the result
with the input sequence using the `mix' function, see below. */
public midi_player SEQ;
/* midi_play SEQ, midi_record SEQ: Variations of the `midi_player' function
which start playback/recording immediately. */
public midi_play SEQ, midi_record SEQ;
/* midi_load NAME: Load the tracks from a MIDI file, mix them down to a single
sequence, and convert timestamps to milliseconds. The result can be played
back with the `midi_player' function. Note that track numbers are
zero-based, so the first track is track #0, the second one track #1,
etc. */
public midi_load NAME;
/* midi_save NAME SEQ: Save the given sequence (with timestamps in
milliseconds) in a type 1 MIDI file, assuming a resolution ("division") of
120 PPQN and a default tempo of 120 BPM (you can change these defaults in
the CONFIG SECTION below). */
public midi_save NAME SEQ;
/* track_nums SEQ: Return the list of all track numbers in a sequence. */
public track_nums SEQ;
/* track N SEQ: Create a single track from a list of events. N denotes the
track number, and SEQ a list of (TIME,MSG) pairs. Shorthand for `map (cons
N) SEQ'. */
public track N SEQ;
/* get_track N SEQ: Extract track N from the given sequence. */
public get_track N SEQ;
/* del_track N SEQ: Delete track N from the given sequence. */
public del_track N SEQ;
/* mix SEQ1 SEQ2: Mix two sequences. */
public mix SEQ1 SEQ2;
/****************************************************************************/
/* START OF CONFIG SECTION. */
/****************************************************************************/
/* Here are some definitions you might want to customize for your local
configuration. */
public var PPQN, BPM, MIDI_IN, MIDI_OUT, PORT;
/* PPQN, BPM. Division and default tempo. This affects the reading and writing
of MIDI files. You might wish to change the PPQN value to something larger
to increase the resolution of saved MIDI files. */
def PPQN = 120, BPM = 120;
/* MIDI_IN, MIDI_OUT, PORT. The MIDI I/O devices and output port. Defaults to
MIDIDEV!0 for both input and output. You might wish to change this to
redirect I/O to other devices listed in mididev.q */
def (_,MIDI_IN,_) = MIDIDEV!0, (_,MIDI_OUT,PORT) = MIDIDEV!0;
/****************************************************************************/
/* END OF CONFIG SECTION. No need to edit below this line. */
/****************************************************************************/
/* Determine the scheduling policy and the corresponding maximum priority.
The latter value is system-dependent, so we have to check it at startup. */
def POL = SCHED_RR, PRIO = maxprio;
testprio PRIO = setsched this_thread 0 0 || true
where () = setsched this_thread POL PRIO;
= false otherwise;
maxprio = until (neg testprio) (+1) 1 - 1;
/* Determine the installation prefix. */
prefix NAME = substr ANAME 0 (#ANAME-2)
where ANAME:String = which NAME;
= NAME otherwise;
/* Main program. This is to be executed when we are invoked from the command
line. */
main ARGS = fprintf ERROR "%s: this program requires Q version >= 4.1\n"
(ARGS!0) || exit 1
if version < "4.1";
= fprintf ERROR "%s: %s could not be found, please check your installation\n"
(ARGS!0,FNAME) || exit 1
if not isfile (fopen FNAME "r")
where FNAME = prefix "midi_player"++".tcl";
= fprintf ERROR "USAGE: %s [midi-file]\n" (ARGS!0) || exit 1
if (#ARGS>2) or else (#ARGS=2) and then
((ARGS!1="-h") or else (ARGS!1="-help"));
= midi_play (ARGS!1) || exit 0
if #ARGS > 1;
= midi_player [] || exit 0
otherwise;
/* Internal clients used by the `midi_player' function. */
def MAIN = midi_open "Player", PLAY = midi_open "Playback",
REC = midi_open "Recorder";
connect = midi_connect MAIN PLAY ||
midi_connect MAIN REC ||
midi_connect MIDI_IN PLAY ||
midi_connect MIDI_IN REC ||
midi_connect REC MIDI_OUT ||
midi_connect PLAY MIDI_OUT;
disconnect = midi_disconnect MAIN PLAY ||
midi_disconnect MAIN REC ||
midi_disconnect MIDI_IN PLAY ||
midi_disconnect MIDI_IN REC ||
midi_disconnect REC MIDI_OUT ||
midi_disconnect PLAY MIDI_OUT;
/* Tk error handler. */
tk_error S = throw '(tk_error S);
tk_reads = "midi_player::quit_cb" if not tk_ready;
/* Set up communication channels between the main thread and the background
tasks. */
def SEM = sem, REC_SEM = sem;
type Msg = const start_rec_msg T S, stop_rec_msg T S,
start_play_msg T S, stop_play_msg T S,
end_msg T S, exit_msg T S,
midi_msg T S TRK MSG;
flush_sem SEM = get SEM || flush_sem SEM if get_size SEM > 0;
= () otherwise;
/* The main function. */
/* This function invokes two background tasks: the playback thread which is
responsible for playing back the sequence, and the recorder thread which
keeps track of incoming events. The main thread merely executes the Tk GUI
and listens for progress reports from the background tasks. */
midi_player SEQ = player update_state SEQ;
player F SEQ = init_app SEQ || flush_sem SEM ||
main_loop
(F (init_pos (update_title (init_state SEQ))))
if islist SEQ or else isstr SEQ;
/* Variations of the midi_player function which start playback/recording
immediately. */
midi_play SEQ = player play_cb SEQ;
midi_record SEQ = player record_cb SEQ;
/* Manage application state. The state of the application is stored in a
hashed dictionary with the following keys:
Name: name of the sequence if loaded from a file
Playseq: the playback sequence; includes the input sequences and all
recorded events
Recseq: current sequence of recorded events
Playtask: the playback thread if any, () otherwise
Rectask: the recorder thread if any, () otherwise
Start: start of the playback sequence (sequence time)
Len: current length of the playback sequence in milliseconds
Offs: absolute offset in milliseconds (sequence time)
Trk: the track incoming events are recorded on */
var Name, Playseq, Recseq, Playtask, Rectask, Start, Len, Offs, Trk;
init_state SEQ:List
= midi_accept_type REC active_sense false ||
midi_accept_type REC clock false ||
connect ||
set_status
(sprintf "%d events in %d tracks" (#SEQ,TRK)) ||
hdict
[(Name,()),
(Playseq,SEQ),(Recseq,[]),
(Playtask,()),(Rectask,()),
(Start,START),(Len,LEN),(Offs,START),(Trk,TRK)]
where START = seq_start SEQ, LEN = seq_len SEQ,
TRK = seq_max_track SEQ + 1;
init_state NAME:String
= midi_accept_type REC active_sense false || connect ||
open_file
(hdict
[(Name,()),
(Playseq,[]),(Recseq,[]),
(Playtask,()),(Rectask,()),
(Start,0),(Len,0),(Offs,0),(Trk,1)]) NAME;
fini_state STATE
= midi_send MAIN PORT stop ||
result (STATE!Playtask) || result (STATE!Rectask) ||
process_all STATE ||
disconnect ||
STATE!Recseq;
reinit_state STATE NAME SEQ:List
= kill STATE ||
hdict [(Name,NAME),
(Playseq,SEQ),(Recseq,[]),
(Playtask,()),(Rectask,()),
(Start,START),(Len,LEN),(Offs,START),(Trk,TRK)]
where START = seq_start SEQ, LEN = seq_len SEQ,
TRK = seq_max_track SEQ + 1;
kill STATE = process_all STATE
if not playing STATE and not recording STATE;
kill STATE = midi_send MAIN PORT stop ||
result (STATE!Playtask) || result (STATE!Rectask) ||
process_all (foldl insert STATE [(Playtask,()),(Rectask,())])
otherwise;
name STATE = STATE!Name;
playseq STATE = STATE!Playseq;
recseq STATE = STATE!Recseq;
start_time STATE
= STATE!Start;
length STATE = STATE!Len;
offset STATE = STATE!Offs;
track STATE = STATE!Trk;
playing STATE = isthread (STATE!Playtask);
recording STATE = isthread (STATE!Rectask);
new_track STATE = update STATE Trk (STATE!Trk+1);
set_name STATE NAME
= update STATE Name NAME;
set_offset STATE OFFS
= update STATE Offs OFFS;
start_play STATE PLAYTASK
= update STATE Playtask PLAYTASK;
start_record STATE RECTASK
= update STATE Rectask RECTASK;
stop_play STATE OFFS
= STATE
if not playing STATE;
= result (STATE!Playtask) ||
update STATE Playtask ()
if recording STATE;
= result (STATE!Playtask) ||
foldl insert STATE [(Playtask,()),(Offs,OFFS)];
stop_record STATE
= STATE if not recording STATE;
stop_record STATE
= result (STATE!Playtask) ||
set_status
(sprintf "%d events recorded on track #%d"
(#SEQ,STATE!Trk)) ||
init_pos
(process_all
foldl insert STATE
[(Playseq,PLAYSEQ),(Recseq,RECSEQ),
(Playtask,()),(Rectask,()),
(Start,START),(Len,LEN),(Offs,OFFS)])
where SEQ = result (STATE!Rectask),
PLAYSEQ = mix (STATE!Playseq) SEQ,
RECSEQ = mix (STATE!Recseq) SEQ,
START = seq_start PLAYSEQ,
LEN = seq_len PLAYSEQ,
OFFS = START + time_diff (STATE!Start) (STATE!Offs);
abort_record STATE
= result (STATE!Playtask) ||
set_status
(sprintf "%d events scratched from track #%d"
(#SEQ,STATE!Trk)) ||
update_pos
(process_all
(foldl insert STATE [(Playtask,()),(Rectask,())]))
where SEQ = result (STATE!Rectask);
/* Initialize the Tk GUI. */
init_app SEQ = tk_quit || tk "wm withdraw ." ||
tk "set argc 0; set argv {}" ||
tk (sprintf "source %s"
(str (prefix "midi_player"++".tcl"))) ||
tk "proc exit { {returnCode 0} } { q midi_player::quit_cb }" ||
tk "wm protocol $widget(Toplevel) WM_DELETE_WINDOW exit" ||
// define some color tags for the text display
tk "$widget(Text1) tag configure Red -foreground red4" ||
tk "$widget(Text1) tag configure Green -foreground green4" ||
tk "$widget(Text1) tag configure Blue -foreground blue4" ||
tk "$widget(Text1) tag configure Black -foreground black";
/* The main loop of the application. Keep processing callbacks and progress
reports from the background threads until the application is exited. */
main_loop STATE = STATE if not tk_ready;
= main_loop (tk_read STATE) if tk_check;
= main_loop (process STATE (get SEM))
if get_size SEM > 0;
= sleep 0.1 || main_loop STATE otherwise;
/* Handle messages sent by the player and recorder threads. */
process STATE (midi_msg T S TRK MSG)
= print T (TRK,DS,MSG) || set_pos DS || STATE
where DS = time_diff (start_time STATE) S;
process STATE (start_rec_msg T S)
= print T "recording started" || STATE;
process STATE (stop_rec_msg T S)
= print T "recording stopped" ||
update_state (stop_record STATE);
process STATE (start_play_msg T S)
= print T "playback started" || STATE;
process STATE (stop_play_msg T S)
= print T "playback stopped" ||
update_state (stop_play STATE S);
process STATE (end_msg T S)
= print T "playback ended" ||
update_state (stop_play STATE (S+1));
process STATE (exit_msg T S)
= update_state (stop_play STATE (offset STATE));
process_all STATE
= process_all (process STATE (get SEM)) if get_size SEM > 0;
= STATE otherwise;
/* Update the state of the interface. */
// quote Tcl/Tk strings
tkstr S:String = sprintf "\"%s\"" (strcat (map tkch (chars S)));
tkch "{" = "\\{";
tkch "}" = "\\}";
tkch "[" = "\\[";
tkch "]" = "\\]";
tkch "$" = "\\$";
tkch "\\" = "\\\\";
tkch "\"" = "\\\"";
tkch C = C otherwise;
clear_log = tk "$widget(Text1) delete 1.0 end";
set_title NAME = tk "wm title $widget(Toplevel) {Q-Midi Player}"
if null NAME;
= tk (sprintf "wm title $widget(Toplevel) %s"
(tkstr (sprintf "%s - Q-Midi Player" NAME)))
otherwise;
set_status MSG = tk_set "status" MSG;
set_mode MSG = tk_set "mode" MSG;
set_track N = tk_set "track" (sprintf "#%d" N);
set_pos T = tk_set "pos" (str (T div 100));
update_state STATE
= set_mode "REC" ||
tk "$widget(RecordButton) configure -relief sunken" ||
tk "$widget(PlayButton) configure -state disabled" ||
tk "$widget(CancelButton) configure -state normal" ||
tk "$widget(StopButton) configure -state normal" ||
tk "$widget(StartButton) configure -state disabled" ||
tk "$widget(EndButton) configure -state disabled" ||
tk "$widget(SongPosScale) configure -state disabled" ||
STATE
if recording STATE;
= set_mode "PLAY" ||
tk "$widget(PlayButton) configure -relief sunken" ||
tk "$widget(RecordButton) configure -state disabled" ||
tk "$widget(CancelButton) configure -state disabled" ||
tk "$widget(StopButton) configure -state normal" ||
tk "$widget(StartButton) configure -state disabled" ||
tk "$widget(EndButton) configure -state disabled" ||
tk "$widget(SongPosScale) configure -state disabled" ||
STATE
if playing STATE;
= set_mode "IDLE" ||
tk "$widget(PlayButton) configure -relief raised" ||
tk "$widget(RecordButton) configure -relief raised" ||
tk "$widget(PlayButton) configure -state normal" ||
tk "$widget(RecordButton) configure -state normal" ||
tk "$widget(CancelButton) configure -state disabled" ||
tk "$widget(StopButton) configure -state disabled" ||
tk "$widget(StartButton) configure -state normal" ||
tk "$widget(EndButton) configure -state normal" ||
tk "$widget(SongPosScale) configure -state normal" ||
STATE
otherwise;
init_pos STATE = tk (sprintf "$widget(SongPosScale) configure -to %d"
(length STATE div 100)) ||
update_pos STATE;
update_pos STATE
= set_pos (offset STATE-start_time STATE) ||
STATE;
update_title STATE
= set_title (name STATE) || set_track (track STATE) || STATE;
/* Print MIDI events. */
print T MSG:String
= tk (sprintf "$widget(Text1) insert end {%-8d }" T) ||
tk (sprintf "$widget(Text1) insert end {*** %s ***} Red {\n}" MSG) ||
tk "$widget(Text1) see end";
print T (TRK,S,MSG)
= tk (sprintf "$widget(Text1) insert end {%-8d %s %-3d }"
(T,time_str S,TRK)) ||
tk (sprintf "$widget(Text1) insert end {%-20s} %s"
(str MSG,tag MSG)) ||
tk (sprintf "$widget(Text1) insert end { %s} %s {\n}"
(note_name MSG,note_tag MSG)) ||
tk "$widget(Text1) see end";
tag MSG = "Green" if is_meta MSG;
= "Red" if is_midishare_specific MSG;
= "Black" if is_voice MSG;
= "Blue" otherwise;
var note_names;
def note_names = ("C","C#","D","Eb","E","F","F#","G","G#","A","Bb","B");
note_name (note_on C P V)
= sprintf "%-2s%d" (note_names!(P mod 12), P div 12);
note_name (note_off C P V)
= sprintf "%-2s%d" (note_names!(P mod 12), P div 12);
note_name (note C P V D)
= sprintf "%-2s%d" (note_names!(P mod 12), P div 12);
note_name MSG = "" otherwise;
note_tag (note_on C P 0)
= "Green";
note_tag (note_on C P V)
= "Red";
note_tag (note_off C P V)
= "Green";
note_tag (note C P V D)
= "Blue";
note_tag MSG = "Black" otherwise;
/* Callback definitions. */
new_cb STATE = set_status "created new sequence" ||
set_pos 0 ||
update_state
(init_pos (update_title (reinit_state STATE () [])));
open_cb STATE = open_file STATE open_dg;
save_cb STATE = save_file STATE (save_dg (name STATE));
save_as_cb STATE
= save_file STATE save_as_dg;
new_track_cb STATE
= set_status
(sprintf "created new track #%d" (track STATE1)) ||
update_title STATE1
otherwise
where STATE1 = new_track STATE;
clear_log_cb STATE
= clear_log || STATE;
quit_cb STATE = tk_quit || FIN where FIN = fini_state STATE;
play_cb STATE = STATE
if playing STATE or else recording STATE;
= flush_sem REC_SEM ||
update_state
(start_play STATE
(thread (setsched this_thread POL PRIO ||
play_midi (offset STATE) (playseq STATE))))
otherwise;
record_cb STATE = STATE
if playing STATE or else recording STATE;
= flush_sem REC_SEM ||
update_state
(start_play
(start_record STATE
(thread (setsched this_thread POL PRIO ||
record_midi (offset STATE) (track STATE))))
(thread (setsched this_thread POL PRIO ||
play_midi (offset STATE) (playseq STATE))))
otherwise;
stop_cb STATE = midi_send MAIN PORT stop || STATE
if playing STATE or else recording STATE;
= STATE
otherwise;
cancel_cb STATE = midi_send MAIN PORT stop || abort_record STATE
if recording STATE;
= STATE
otherwise;
start_cb STATE = STATE
if playing STATE or else recording STATE;
start_cb STATE = update_pos (set_offset STATE (start_time STATE));
end_cb STATE = STATE
if playing STATE or else recording STATE;
end_cb STATE = update_pos (set_offset STATE
(start_time STATE+length STATE+1));
pos_cb STATE = STATE
if playing STATE or else recording STATE;
pos_cb POS STATE
= set_offset STATE (start_time STATE+POS*100);
about_cb STATE = about_dg "Q-Midi Player V1.2 01-05-04\n\n\
Copyright (c) 2002-04 by Albert Graef\n\
<Dr....@t-...>" ||
STATE;
/* Open and save MIDI files. */
open_file STATE ()
= STATE;
open_file STATE NAME
= set_status
(sprintf "%d events in %d tracks loaded from %s"
(#SEQ,track STATE1,NAME)) ||
set_pos 0 || update_state (init_pos (update_title STATE1))
where SEQ:List = set_status "loading..." || midi_load NAME,
STATE1 = reinit_state STATE NAME SEQ;
= set_status (sprintf "error loading %s" NAME) ||
open_err_dg NAME || STATE otherwise;
save_file STATE ()
= STATE;
save_file STATE NAME
= set_status
(sprintf "%d events in %d tracks saved in %s"
(#SEQ,track STATE+ifelse (null SEQ2) 0 1,NAME)) ||
update_title (set_name STATE NAME)
if eq () (set_status "saving..." || midi_save NAME SEQ)
where SEQ = playseq STATE, SEQ2 = recseq STATE;
= set_status (sprintf "error saving %s" NAME) ||
save_err_dg NAME || STATE otherwise;
/* Dialog definitions. */
open_dg = tk "tk_getOpenFile -title \"Open...\" \
-parent $widget(Toplevel) \
-defaultextension \".mid\" \
-filetypes {{{MIDI Files} {.mid}} {{All Files} *}}";
save_dg NAME = save_as_dg if null NAME;
= NAME otherwise;
save_as_dg = tk "tk_getSaveFile -title \"Save as...\" \
-parent $widget(Toplevel) \
-defaultextension \".mid\" \
-filetypes {{{MIDI Files} {.mid}} {{All Files} *}}";
open_err_dg NAME
= tk "tk_messageBox -icon error -title Error -type ok \
-parent $widget(Toplevel) \
-message \"Error opening MIDI file\"";
save_err_dg NAME
= tk "tk_messageBox -icon error -title Error -type ok \
-parent $widget(Toplevel) \
-message \"Error saving MIDI file\"";
about_dg MSG = tk (sprintf "tk_messageBox -parent $widget(Toplevel) \
-parent $widget(Toplevel) \
-icon info -title {About Q-Midi Player} -type ok -message %s" (str MSG));
/* The playback loop. */
play_midi OFFS SEQ
= midi_flush PLAY || play0 OFFS SEQ;
play0 OFFS SEQ = post REC_SEM midi_time ||
post SEM (exit_msg T 0) if null SEQ;
play0 OFFS [(TRK,S,MSG)|SEQ]
= play1 midi_time S [(TRK,S,MSG)|SEQ]
if S >= OFFS;
= midi_send PLAY PORT MSG || play0 OFFS SEQ
if not is_note_on MSG and then not is_note_off MSG
and then not is_note MSG;
= play0 OFFS SEQ
otherwise;
play1 T S SEQ = post REC_SEM T || post SEM (start_play_msg T S) ||
play2 emptybag T S SEQ;
play2 NOTES T S []
= post SEM (end_msg T S);
play2 NOTES T S SEQ
= all_notes_off T S NOTES || post SEM (stop_play_msg T S)
if midi_avail PLAY and then
is_stop (midi_get PLAY!3);
play2 NOTES T1 S1 [(TRK,S2,MSG)|SEQ]
= //check_time 0 midi_time T1 ||
midi_send PLAY PORT MSG ||
post SEM (midi_msg T1 S1 TRK MSG) ||
play2 (save_notes NOTES MSG) T1 S1 SEQ
if S2 = S1;
= //check_time (S2-S1) midi_time T2 ||
midi_send PLAY PORT MSG ||
post SEM (midi_msg T2 S2 TRK MSG) ||
play2 (save_notes NOTES MSG) T2 S2 SEQ
where T2:Int =
midi_wait_loop PLAY T1 (time_diff S1 S2 + T1);
= all_notes_off T2 S2 NOTES || post SEM (stop_play_msg T2 S2)
where T2 = time_diff S1 S2 + T1
otherwise;
// interruptible wait
def TICKS = 100;
midi_wait_loop REF T1 T2
= midi_send MAIN PORT stop || ()
if midi_avail PLAY and then
is_stop (midi_get PLAY!3);
= T2 if T2 <= T1;
= midi_wait REF T2 if T2-T1 <= TICKS;
= midi_wait_loop REF T1 T2
where T1 = midi_wait REF (T1+TICKS);
// report timing glitches >= 20ms, for testing purposes
check_time DT T1 T2
= printf "%d ms late (delta = %d)!\n" (T1-T2,DT) if T1-T2>=20;
save_notes NOTES (note_on CHAN PITCH VEL)
= insert NOTES [CHAN,PITCH] if VEL > 0;
= delete NOTES [CHAN,PITCH] otherwise;
save_notes NOTES (note_off CHAN PITCH VEL)
= delete NOTES [CHAN,PITCH];
save_notes NOTES _
= NOTES otherwise;
all_notes_off T S NOTES
= do (lambda [CHAN,PITCH]
(midi_send PLAY PORT (note_on CHAN PITCH 0)))
(members NOTES);
/* The recording loop. */
record_midi OFFS TRK
= midi_flush REC || post SEM (start_rec_msg TIME OFFS) ||
rec TRK TIME OFFS [] (midi_get REC)
where TIME = get REC_SEM;
rec TRK T0 S0 SEQ (_,_,T,stop)
= post SEM (stop_rec_msg T S) || SEQ
where S = S0 + time_diff T0 T;
rec TRK T0 S0 SEQ (_,_,T,MSG)
= midi_send REC PORT MSG ||
post SEM (midi_msg T S TRK MSG) ||
rec TRK T0 S0 (append SEQ (TRK,S,MSG)) (midi_get REC)
where S = S0 + time_diff T0 T;
/* Load a sequence from a MIDI file. */
midi_load NAME:String
= convert (midi_file_division F) (60000000 div BPM) 0 0
(foldl mix [] (tracks F))
where F = midi_file_open NAME;
// read the tracks from a MIDI file
tracks F = listof (map (cons I) (midi_file_read_track F))
(I in nums 0 (midi_file_num_tracks F-1));
// convert timestamps
convert _ _ _ _ []
= [];
convert (FPS,FRACS) TEMPO T0 MS0 [(TRK,T,MSG)|SEQ]
= [(TRK,MS,MSG)|convert (FPS,FRACS) TEMPO T0 MS0 SEQ]
where MS = round (T/(FPS*FRACS)*1000);
convert PPQN TEMPO T0 MS0 [(TRK,T,tempo TEMPO1)|SEQ]
= [(TRK,MS,tempo TEMPO1)|convert PPQN TEMPO1 T MS SEQ]
where MS = MS0+round (TEMPO/PPQN*(T-T0)/1000);
convert PPQN TEMPO T0 MS0 [(TRK,T,MSG)|SEQ]
= [(TRK,MS,MSG)|convert PPQN TEMPO T MS SEQ]
where MS = MS0+round (TEMPO/PPQN*(T-T0)/1000);
/* Save a sequence in a MIDI file. */
midi_save NAME:String SEQ:List
= do (write_track F SEQ) (track_nums SEQ)
where F:MidiFile = midi_file_create NAME 1 PPQN;
// write a single track
write_track F SEQ N
= midi_file_write_track F
(extract (60000000 div BPM) 0 0 (seq_start SEQ) N SEQ);
// extract: extract a track from the sequence, convert timestamps to ticks;
// the arguments are as follows:
// TEMPO: current TEMPO of the sequence
// U: current end time of track N
// T0, S0: current time in ticks (Midi file time) and milliseconds
// (sequence time)
// N: number of track to extract
// SEQ: rest of the sequence to process
extract TEMPO U T0 S0 N []
= [(U,end_track)];
extract TEMPO U T0 S0 N [(M,S,end_track)|SEQ]
= extract TEMPO U (T0+ticks TEMPO (time_diff S0 S)) S N SEQ
if N<>M;
= [(U,end_track)]
otherwise;
extract TEMPO U T0 S0 N [(M,S,tempo TEMPO1)|SEQ]
= extract TEMPO1 U (T0+ticks TEMPO (time_diff S0 S)) S N SEQ
if N<>M;
= [(T0+DT,tempo TEMPO1)|
extract TEMPO1 (T0+DT) (T0+DT) S N SEQ]
otherwise
where DT = ticks TEMPO (time_diff S0 S);
extract TEMPO U T0 S0 N [(M,S,MSG)|SEQ]
= extract TEMPO U (T0+ticks TEMPO (time_diff S0 S)) S N SEQ
if N<>M;
= [(T0+DT,MSG)|
extract TEMPO (T0+DT) (T0+DT) S N SEQ]
otherwise
where DT = ticks TEMPO (time_diff S0 S);
// convert millisecs to ticks, on the basis of the PPQN value and the current
// TEMPO
ticks TEMPO TIME
= round (TIME*1000/TEMPO*PPQN);
/* Return the list of track numbers of a sequence. */
track_nums SEQ:List
= members (foldl insert emptyset (map fst SEQ));
/* Create a track from an event list. */
track N:Int SEQ:List
= map (cons N) SEQ;
/* Extract a track from a sequence. */
get_track N:Int SEQ:List
= filter (lambda (M|EV) (N=M)) SEQ;
/* Delete a track from a sequence. */
del_track N:Int SEQ:List
= filter (lambda (M|EV) (N<>M)) SEQ;
/* Mix two multi-track sequences. */
mix SEQ1:List SEQ2:List
= SEQ1 if null SEQ2;
= SEQ2 if null SEQ1;
= [hd SEQ1|mix (tl SEQ1) SEQ2] if T1 <= T2
where (_,T1,_) = hd SEQ1, (_,T2,_) = hd SEQ2;
= [hd SEQ2|mix SEQ1 (tl SEQ2)] otherwise;
/* Miscellaneous helper functions. */
time_str TIME = sprintf "%d:%02d:%03d" (MIN,SECS,MSECS)
where MIN = TIME div 60000,
SECS = (TIME mod 60000) div 1000,
MSECS = TIME mod 1000;
time_diff T1 T2 = ifelse (DT>=0) DT (DT+0x100000000)
where DT = T2 mod 0x100000000 - T1 mod 0x100000000;
seq_start SEQ = T where (_,T,_) = hd SEQ;
= 0 otherwise;
seq_end SEQ = T where (_,T,_) = last SEQ;
= 0 otherwise;
seq_len SEQ = time_diff (seq_start SEQ) (seq_end SEQ);
seq_max_track SEQ
= foldl max (-1) (map fst SEQ);
--- NEW FILE: midi_player.tcl ---
#!/bin/sh
# the next line restarts using wish\
exec wish "$0" "$@"
if {![info exists vTcl(sourcing)]} {
switch $tcl_platform(platform) {
windows {
option add *Button.padY 0
}
default {
option add *Scrollbar.width 10
option add *Scrollbar.highlightThickness 0
option add *Scrollbar.elementBorderWidth 2
option add *Scrollbar.borderWidth 2
}
}
}
#############################################################################
# Visual Tcl v1.60 Project
#
#############################################################################
## vTcl Code to Load Stock Images
if {![info exist vTcl(sourcing)]} {
#############################################################################
## Procedure: vTcl:rename
proc {vTcl:rename} {name} {
regsub -all "\\." $name "_" ret
regsub -all "\\-" $ret "_" ret
regsub -all " " $ret "_" ret
regsub -all "/" $ret "__" ret
regsub -all "::" $ret "__" ret
return [string tolower $ret]
}
#############################################################################
## Procedure: vTcl:image:create_new_image
proc {vTcl:image:create_new_image} {filename {description {no description}} {type {}} {data {}}} {
global vTcl env
# Does the image already exist?
if {[info exists vTcl(images,files)]} {
if {[lsearch -exact $vTcl(images,files) $filename] > -1} { return }
}
if {![info exists vTcl(sourcing)] && [string length $data] > 0} {
set object [image create [vTcl:image:get_creation_type $filename] -data $data]
} else {
# Wait a minute... Does the file actually exist?
if {! [file exists $filename] } {
# Try current directory
set script [file dirname [info script]]
set filename [file join $script [file tail $filename] ]
}
if {![file exists $filename]} {
set description "file not found!"
set object [image create photo -data [vTcl:image:broken_image] ]
} else {
set object [image create [vTcl:image:get_creation_type $filename] -file $filename]
}
}
set reference [vTcl:rename $filename]
set vTcl(images,$reference,image) $object
set vTcl(images,$reference,description) $description
set vTcl(images,$reference,type) $type
set vTcl(images,filename,$object) $filename
lappend vTcl(images,files) $filename
lappend vTcl(images,$type) $object
# return image name in case caller might want it
return $object
}
#############################################################################
## Procedure: vTcl:image:get_image
proc {vTcl:image:get_image} {filename} {
set reference [vTcl:rename $filename]
# Let's do some checking first
if {![info exists ::vTcl(images,$reference,image)]} {
# Well, the path may be wrong; in that case check
# only the filename instead, without the path.
set imageTail [file tail $filename]
foreach oneFile $::vTcl(images,files) {
if {[file tail $oneFile] == $imageTail} {
set reference [vTcl:rename $oneFile]
break
}
}
}
return $::vTcl(images,$reference,image)
}
#############################################################################
## Procedure: vTcl:image:get_creation_type
proc {vTcl:image:get_creation_type} {filename} {
switch [string tolower [file extension $filename]] {
.ppm -
.jpg -
.bmp -
.gif {return photo}
.xbm {return bitmap}
default {return photo}
}
}
#############################################################################
## Procedure: vTcl:image:broken_image
proc {vTcl:image:broken_image} {} {
return {
R0lGODdhFAAUAPcAAAAAAIAAAACAAICAAAAAgIAAgACAgMDAwICAgP8AAAD/
AP//AAAA//8A/wD//////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAACwAAAAAFAAUAAAIhAAPCBxIsKDBgwgPAljIUOBC
BAkBPJg4UeBEBBAVPkCI4EHGghIHChAwsKNHgyEPCFBA0mFDkBtVjiz4AADK
mAds0tRJMCVBBkAl8hwYMsFPBwyE3jzQwKhAoASUwmTagCjDmksbVDWIderC
g1174gQ71CHFigfOhrXKUGfbrwnjyp0bEAA7
}
}
foreach img {
} {
eval set _file [lindex $img 0]
vTcl:image:create_new_image\
$_file [lindex $img 1] [lindex $img 2] [lindex $img 3]
}
}
#############################################################################
## vTcl Code to Load User Images
catch {package require Img}
foreach img {
{{[file join / home ag src q q-midi images start.gif]} {user image} user {
R0lGODlhEAAPAPIDAAAAAI6OjpSVlP///////wAAAAAAAAAAACH5BAEAAAQA
LAAAAAAQAA8AAAONKCIigkREREgkIoAAMURIRESCMAIAGENEhEQCMSgAEINE
RCQIECOAADFESCQAgDECABhDRIIAADEoABCDRAIACBAjgAAxJAgAAIAxAgAY
QySAAAAxKAAQg0QkAAgQI4AAMURIJACAMQIAGENEhCQAMSgAEINEREQoECOA
ETFESEREgjAyMzhDRIRERDIJADs=}}
{{[file join / home ag src q q-midi images play.gif]} {user image} user {
R0lGODlhDQAPAPIDAAAAAI6OjpSVlP///////wAAAAAAAAAAACH5BAEAAAQA
LAAAAAANAA8AAANzKCIigkREREgCAIAgRERIJACAACBESEQCgAAAIEhEJIAA
AAAIQkSCAAAACABChAIAAAgAAIIkAAAIAACAMQIACAAAgDEkAAgAAIAxRAII
AACAMUQkCAAAgDFERCgAAIAxRERIAhGBMURESCQzgzNEREhECQA7}}
{{[file join / home ag src q q-midi images record.gif]} {user image} user {
R0lGODlhDQAPAPIEAAAAAMAAAI6OjpSVlP///////wAAAAAAACH5BAEAAAUA
LAAAAAANAA8AAANzODMzg1VVVVgTEYExVVVYNRGBETFVWFUTgRERMVhVNYER
EREYU1WDERERGBFThRMRERgREYM1EREYERGBQhMRGBERgUI1ERgREYFCVRMY
ERGBQlU1GBERgUJVVTgREYFCVVVYEyKCQlVVWDVEhERVVVhVCQA7}}
{{[file join / home ag src q q-midi images stop.gif]} {user image} user {
R0lGODlhDQAPAPIDAAAAAI6OjpSVlP///////wAAAAAAAAAAACH5BAEAAAQA
LAAAAAANAA8AAANzKCIigiIiIigCAIAAAAAYIwCAAAAACDECgAAAAAgQI4AA
AAAIADGCAAAACAAQgwIAAAgAAIEjAAAIAACAMQIACAAAgBAjAAgAAIAAMQII
AACAABAjCAAAgAAAMSgAAIAAABA4AhGBERERGCMzgzMzMzgzCQA7}}
{{[file join / home ag src q q-midi images cancel.gif]} {user image} user {
R0lGODlhEQAPAPECAAAAAIAAAP///wAAACH5BAEAAAIALAAAAAARAA8AAAKQ
lChRokSJEiVKlChRokSJEiVKlChRYUSJEiUmlChRYsKIEiUmjChRosSEESUm
jChRokSJCSMmjChRokSJEhMmjChRokSJEiUmjChRokSJEiUmTBhRokSJEiUm
jJgwokSJEiUmjCgxYUSJEiUmjChRYsKIEiUqjChRosSEEiVKlChRokSJEiVK
lChRokSJEiWqADs=}}
{{[file join / home ag src q q-midi images end.gif]} {user image} user {
R0lGODlhEAAPAPIDAAAAAI6OjpSVlP///////wAAAAAAAAAAACH5BAEAAAQA
LAAAAAAQAA8AAAONKEJEhEREIigiIoBCRERIJACAMQIgSEREhAIAMSgAIIRE
RAIIECOAACBESCQAgDECAAggRIQCADEoAACAIEQCCBAjgAAAEDgkAIAxAgAI
EEOEAgAxKAAAgUNEAggQI4AAMURIJACAMQIQOEREhAIAMSgQQ4RERAIIECOA
Q0RESCQQgTEyREhERIQyMzMJADs=}}
} {
eval set _file [lindex $img 0]
vTcl:image:create_new_image\
$_file [lindex $img 1] [lindex $img 2] [lindex $img 3]
}
#################################
# VTCL LIBRARY PROCEDURES
#
if {![info exists vTcl(sourcing)]} {
#############################################################################
## Library Procedure: Window
proc {Window} {args} {
global vTcl
set cmd [lindex $args 0]
set name [lindex $args 1]
set newname [lindex $args 2]
set rest [lrange $args 3 end]
if {$name == "" || $cmd == ""} { return }
if {$newname == ""} { set newname $name }
if {$name == "."} { wm withdraw $name; return }
set exists [winfo exists $newname]
switch $cmd {
show {
if {$exists} {
wm deiconify $newname
} elseif {[info procs vTclWindow$name] != ""} {
eval "vTclWindow$name $newname $rest"
}
if {[winfo exists $newname] && [wm state $newname] == "normal"} {
vTcl:FireEvent $newname <<Show>>
}
}
hide {
if {$exists} {
wm withdraw $newname
vTcl:FireEvent $newname <<Hide>>
return}
}
iconify { if $exists {wm iconify $newname; return} }
destroy { if $exists {destroy $newname; return} }
}
}
#############################################################################
## Library Procedure: vTcl:DefineAlias
proc {vTcl:DefineAlias} {target alias widgetProc top_or_alias cmdalias} {
global widget
set widget($alias) $target
set widget(rev,$target) $alias
if {$cmdalias} {
interp alias {} $alias {} $widgetProc $target
}
if {$top_or_alias != ""} {
set widget($top_or_alias,$alias) $target
if {$cmdalias} {
interp alias {} $top_or_alias.$alias {} $widgetProc $target
}
}
}
#############################################################################
## Library Procedure: vTcl:DoCmdOption
proc {vTcl:DoCmdOption} {target cmd} {
## menus are considered toplevel windows
set parent $target
while {[winfo class $parent] == "Menu"} {
set parent [winfo parent $parent]
}
regsub -all {\%widget} $cmd $target cmd
regsub -all {\%top} $cmd [winfo toplevel $parent] cmd
uplevel #0 [list eval $cmd]
}
#############################################################################
## Library Procedure: vTcl:FireEvent
proc {vTcl:FireEvent} {target event {params {}}} {
## The window may have disappeared
if {![winfo exists $target]} return
## Process each binding tag, looking for the event
foreach bindtag [bindtags $target] {
set tag_events [bind $bindtag]
set stop_processing 0
foreach tag_event $tag_events {
if {$tag_event == $event} {
set bind_code [bind $bindtag $tag_event]
foreach rep "\{%W $target\} $params" {
regsub -all [lindex $rep 0] $bind_code [lindex $rep 1] bind_code
}
set result [catch {uplevel #0 $bind_code} errortext]
if {$result == 3} {
## break exception, stop processing
set stop_processing 1
} elseif {$result != 0} {
bgerror $errortext
}
break
}
}
if {$stop_processing} {break}
}
}
#############################################################################
## Library Procedure: vTcl:Toplevel:WidgetProc
proc {vTcl:Toplevel:WidgetProc} {w args} {
if {[llength $args] == 0} {
## If no arguments, returns the path the alias points to
return $w
}
## The first argument is a switch, they must be doing a configure.
if {[string index $args 0] == "-"} {
set command configure
## There's only one argument, must be a cget.
if {[llength $args] == 1} {
set command cget
}
} else {
set command [lindex $args 0]
set args [lrange $args 1 end]
}
switch -- $command {
"hide" - "Hide" - "show" - "Show" {
Window [string tolower $command] $w
}
"ShowModal" {
Window show $w
raise $w
grab $w
tkwait window $w
grab release $w
}
default {
uplevel $w $command $args
}
}
}
#############################################################################
## Library Procedure: vTcl:WidgetProc
proc {vTcl:WidgetProc} {w args} {
if {[llength $args] == 0} {
## If no arguments, returns the path the alias points to
return $w
}
## The first argument is a switch, they must be doing a configure.
if {[string index $args 0] == "-"} {
set command configure
## There's only one argument, must be a cget.
if {[llength $args] == 1} {
set command cget
}
} else {
set command [lindex $args 0]
set args [lrange $args 1 end]
}
uplevel $w $command $args
}
#############################################################################
## Library Procedure: vTcl:toplevel
proc {vTcl:toplevel} {args} {
uplevel #0 eval toplevel $args
set target [lindex $args 0]
namespace eval ::$target {}
}
}
if {[info exists vTcl(sourcing)]} {
proc vTcl:project:info {} {
set base .top32
namespace eval ::widgets::$base {
set set,origin 0
set set,size 1
}
namespace eval ::widgets::$base.cpd35 {
array set save {-borderwidth 1 -height 1 -width 1}
}
set site_3_0 $base.cpd35
namespace eval ::widgets::$site_3_0.01 {
array set save {-anchor 1 -font 1 -menu 1 -padx 1 -pady 1 -text 1 -width 1}
}
namespace eval ::widgets::$site_3_0.01.02 {
array set save {-activebackground 1 -activeforeground 1 -foreground 1 -tearoff 1}
}
namespace eval ::widgets::$site_3_0.05 {
array set save {-anchor 1 -font 1 -menu 1 -padx 1 -pady 1 -text 1 -width 1}
}
namespace eval ::widgets::$site_3_0.05.06 {
array set save {-activebackground 1 -activeforeground 1 -foreground 1 -tearoff 1}
}
namespace eval ::widgets::$base.fra36 {
array set save {-borderwidth 1 -height 1 -relief 1 -width 1}
}
set site_3_0 $base.fra36
namespace eval ::widgets::$site_3_0.but33 {
array set save {-_tooltip 1 -anchor 1 -command 1 -image 1 -text 1}
}
namespace eval ::widgets::$site_3_0.but36 {
array set save {-_tooltip 1 -anchor 1 -command 1 -image 1 -text 1}
}
namespace eval ::widgets::$site_3_0.but37 {
array set save {-_tooltip 1 -anchor 1 -command 1 -image 1 -text 1}
}
namespace eval ::widgets::$site_3_0.but38 {
array set save {-_tooltip 1 -anchor 1 -command 1 -image 1 -text 1}
}
namespace eval ::widgets::$site_3_0.but34 {
array set save {-_tooltip 1 -command 1 -image 1 -text 1}
}
namespace eval ::widgets::$site_3_0.but40 {
array set save {-_tooltip 1 -anchor 1 -command 1 -image 1 -text 1}
}
namespace eval ::widgets::$site_3_0.sca41 {
array set save {-bigincrement 1 -command 1 -from 1 -orient 1 -resolution 1 -showvalue 1 -tickinterval 1 -to 1 -variable 1}
}
namespace eval ::widgets::$base.cpd37 {
array set save {-borderwidth 1 -height 1 -relief 1 -width 1}
}
set site_3_0 $base.cpd37
namespace eval ::widgets::$site_3_0.01 {
array set save {-command 1 -orient 1}
}
namespace eval ::widgets::$site_3_0.02 {
array set save {-command 1}
}
namespace eval ::widgets::$site_3_0.03 {
array set save {-background 1 -font 1 -height 1 -width 1 -wrap 1 -xscrollcommand 1 -yscrollcommand 1}
}
namespace eval ::widgets::$base.fra43 {
array set save {-borderwidth 1 -height 1 -width 1}
}
set site_3_0 $base.fra43
namespace eval ::widgets::$site_3_0.lab44 {
array set save {-anchor 1 -font 1 -relief 1 -textvariable 1 -width 1}
}
namespace eval ::widgets::$site_3_0.lab46 {
array set save {-font 1 -relief 1 -textvariable 1 -width 1}
}
namespace eval ::widgets::$site_3_0.lab69 {
array set save {-disabledforeground 1 -font 1 -relief 1 -textvariable 1 -width 1}
}
namespace eval ::widgets_bindings {
set tagslist {all _TopLevel _vTclBalloon}
}
namespace eval ::vTcl::modules::main {
set procs {
init
main
vTclWindow.
vTclWindow.top32
}
}
}
}
#################################
# USER DEFINED PROCEDURES
#
#############################################################################
## Procedure: main
proc {main} {argc argv} {
wm protocol .top32 WM_DELETE_WINDOW {exit}
}
#############################################################################
## Initialization Procedure: init
proc {init} {argc argv} {
if {[info command q] == {}} then { proc q { args } { } }
option add *Dialog.msg.font {Helvetica 12}
option add *fra36*Button.borderWidth 1
}
init $argc $argv
#################################
# VTCL GENERATED GUI PROCEDURES
#
proc vTclWindow. {base} {
if {$base == ""} {
set base .
}
###################
# CREATING WIDGETS
###################
wm focusmodel $base passive
wm geometry $base 1x1+0+0; update
wm maxsize $base 1137 834
wm minsize $base 1 1
wm overrideredirect $base 0
wm resizable $base 1 1
wm withdraw $base
wm title $base "vtcl.tcl"
bindtags $base "$base Vtcl.tcl all"
vTcl:FireEvent $base <<Create>>
wm protocol $base WM_DELETE_WINDOW "vTcl:FireEvent $base <<DeleteWindow>>"
###################
# SETTING GEOMETRY
###################
vTcl:FireEvent $base <<Ready>>
}
proc vTclWindow.top32 {base} {
if {$base == ""} {
set base .top32
}
if {[winfo exists $base]} {
wm deiconify $base; return
}
set top $base
###################
# CREATING WIDGETS
###################
vTcl:toplevel $base -class Toplevel \
-highlightcolor black
wm focusmodel $base passive
wm geometry $base 609x422; update
wm maxsize $base 1265 930
wm minsize $base 1 1
wm overrideredirect $base 0
wm resizable $base 1 1
wm deiconify $base
wm title $base "Q-Midi Player"
vTcl:DefineAlias "$base" "Toplevel" vTcl:Toplevel:WidgetProc "" 1
bindtags $base "$base Toplevel all _TopLevel"
vTcl:FireEvent $base <<Create>>
wm protocol $base WM_DELETE_WINDOW "vTcl:FireEvent $base <<DeleteWindow>>"
frame $base.cpd35 \
-borderwidth 1 -height 30 -width 30
vTcl:DefineAlias "$base.cpd35" "MenuFrame" vTcl:WidgetProc "Toplevel" 1
set site_3_0 $base.cpd35
menubutton $site_3_0.01 \
-anchor w -font {Helvetica -12} -menu "$site_3_0.01.02" -padx 4 \
-pady 3 -text File -width 4
vTcl:DefineAlias "$site_3_0.01" "FileButton" vTcl:WidgetProc "Toplevel" 1
menu $site_3_0.01.02 \
-activebackground #dcdcdc -activeforeground #000000 \
-foreground #000000 -tearoff 0
vTcl:DefineAlias "$site_3_0.01.02" "FileMenu" vTcl:WidgetProc "" 1
$site_3_0.01.02 add command \
-accelerator Ctrl+N -command {q midi_player::new_cb} -font {Helvetica -12} \
-label New
$site_3_0.01.02 add command \
-accelerator Ctrl+O -command {q midi_player::open_cb} \
-font {Helvetica -12} -label Open...
$site_3_0.01.02 add command \
-accelerator Ctrl+S -command {q midi_player::save_cb} \
-font {Helvetica -12} -label Save
$site_3_0.01.02 add command \
-command {q midi_player::save_as_cb} -font {Helvetica -12} \
-label {Save as...}
$site_3_0.01.02 add command \
-accelerator Ctrl+K -command {q midi_player::new_track_cb} \
-font {Helvetica -12} -label {New track}
$site_3_0.01.02 add separator
$site_3_0.01.02 add command \
-accelerator Ctrl+C -command {q midi_player::clear_log_cb} \
-font {Helvetica -12} -label {Clear log}
$site_3_0.01.02 add separator
$site_3_0.01.02 add command \
-accelerator Ctrl+Q -command {q midi_player::quit_cb} \
-font {Helvetica -12} -label Quit
menubutton $site_3_0.05 \
-anchor w -font {Helvetica -12} -menu "$site_3_0.05.06" -padx 4 \
-pady 3 -text Help -width 4
vTcl:DefineAlias "$site_3_0.05" "HelpButton" vTcl:WidgetProc "Toplevel" 1
menu $site_3_0.05.06 \
-activebackground #dcdcdc -activeforeground #000000 \
-foreground #000000 -tearoff 0
vTcl:DefineAlias "$site_3_0.05.06" "HelpMenu" vTcl:WidgetProc "" 1
$site_3_0.05.06 add command \
-command {q midi_player::about_cb} -font {Helvetica -12} -label About
pack $site_3_0.01 \
-in $site_3_0 -anchor center -expand 0 -fill none -side left
pack $site_3_0.05 \
-in $site_3_0 -anchor center -expand 0 -fill none -side right
frame $base.fra36 \
-borderwidth 2 -relief ridge -height 37 -width 125
vTcl:DefineAlias "$base.fra36" "ToolbarFrame" vTcl:WidgetProc "Toplevel" 1
set site_3_0 $base.fra36
button $site_3_0.but33 \
-anchor center -command {q midi_player::start_cb} \
-image [vTcl:image:get_image [file join / home ag src q q-midi images start.gif]] \
-text Start
vTcl:DefineAlias "$site_3_0.but33" "StartButton" vTcl:WidgetProc "Toplevel" 1
bindtags $site_3_0.but33 "$site_3_0.but33 Button $top all _vTclBalloon"
bind $site_3_0.but33 <<SetBalloon>> {
set ::vTcl::balloon::%W {Start of sequence}
}
button $site_3_0.but36 \
-anchor center -command {q midi_player::play_cb} \
-image [vTcl:image:get_image [file join / home ag src q q-midi images play.gif]] \
-text Play
vTcl:DefineAlias "$site_3_0.but36" "PlayButton" vTcl:WidgetProc "Toplevel" 1
bindtags $site_3_0.but36 "$site_3_0.but36 Button $top all _vTclBalloon"
bind $site_3_0.but36 <<SetBalloon>> {
set ::vTcl::balloon::%W {Play}
}
button $site_3_0.but37 \
-anchor center -command {q midi_player::record_cb} \
-image [vTcl:image:get_image [file join / home ag src q q-midi images record.gif]] \
-text Record
vTcl:DefineAlias "$site_3_0.but37" "RecordButton" vTcl:WidgetProc "Toplevel" 1
bindtags $site_3_0.but37 "$site_3_0.but37 Button $top all _vTclBalloon"
bind $site_3_0.but37 <<SetBalloon>> {
set ::vTcl::balloon::%W {Record}
}
button $site_3_0.but38 \
-anchor center -command {q midi_player::stop_cb} \
-image [vTcl:image:get_image [file join / home ag src q q-midi images stop.gif]] \
-text Stop
vTcl:DefineAlias "$site_3_0.but38" "StopButton" vTcl:WidgetProc "Toplevel" 1
bindtags $site_3_0.but38 "$site_3_0.but38 Button $top all _vTclBalloon"
bind $site_3_0.but38 <<SetBalloon>> {
set ::vTcl::balloon::%W {Stop}
}
button $site_3_0.but34 \
-command {q midi_player::cancel_cb} \
-image [vTcl:image:get_image [file join / home ag src q q-midi images cancel.gif]] \
-text Cancel
vTcl:DefineAlias "$site_3_0.but34" "CancelButton" vTcl:WidgetProc "Toplevel" 1
bindtags $site_3_0.but34 "$site_3_0.but34 Button $top all _vTclBalloon"
bind $site_3_0.but34 <<SetBalloon>> {
set ::vTcl::balloon::%W {Cancel recording}
}
button $site_3_0.but40 \
-anchor center -command {q midi_player::end_cb} \
-image [vTcl:image:get_image [file join / home ag src q q-midi images end.gif]] \
-text End
vTcl:DefineAlias "$site_3_0.but40" "EndButton" vTcl:WidgetProc "Toplevel" 1
bindtags $site_3_0.but40 "$site_3_0.but40 Button $top all _vTclBalloon"
bind $site_3_0.but40 <<SetBalloon>> {
set ::vTcl::balloon::%W {End of sequence}
}
scale $site_3_0.sca41 \
-bigincrement 0.0 -command {q midi_player::pos_cb} -from 0.0 \
-orient horizontal -resolution 1.0 -showvalue 0 -tickinterval 0.0 \
-to 100.0 -variable pos
vTcl:DefineAlias "$site_3_0.sca41" "SongPosScale" vTcl:WidgetProc "Toplevel" 1
pack $site_3_0.but33 \
-in $site_3_0 -anchor w -expand 0 -fill none -side left
pack $site_3_0.but36 \
-in $site_3_0 -anchor w -expand 0 -fill none -side left
pack $site_3_0.but37 \
-in $site_3_0 -anchor w -expand 0 -fill none -side left
pack $site_3_0.but38 \
-in $site_3_0 -anchor w -expand 0 -fill none -side left
pack $site_3_0.but34 \
-in $site_3_0 -anchor center -expand 0 -fill none -side left
pack $site_3_0.but40 \
-in $site_3_0 -anchor w -expand 0 -fill none -side left
pack $site_3_0.sca41 \
-in $site_3_0 -anchor e -expand 1 -fill x -side right
frame $base.cpd37 \
-borderwidth 1 -relief raised -height 91 -width 30
vTcl:DefineAlias "$base.cpd37" "ScrolledTextFrame" vTcl:WidgetProc "Toplevel" 1
set site_3_0 $base.cpd37
scrollbar $site_3_0.01 \
-command "$site_3_0.03 xview" -orient horizontal
vTcl:DefineAlias "$site_3_0.01" "Scrollbar1" vTcl:WidgetProc "Toplevel" 1
scrollbar $site_3_0.02 \
-command "$site_3_0.03 yview"
vTcl:DefineAlias "$site_3_0.02" "Scrollbar2" vTcl:WidgetProc "Toplevel" 1
text $site_3_0.03 \
-background #ffffff \
-font -Adobe-Courier-Medium-R-Normal-*-*-120-*-*-*-*-*-* -height 10 \
-width 20 -wrap none -xscrollcommand "$site_3_0.01 set" \
-yscrollcommand "$site_3_0.02 set"
vTcl:DefineAlias "$site_3_0.03" "Text1" vTcl:WidgetProc "Toplevel" 1
grid $site_3_0.01 \
-in $site_3_0 -column 0 -row 1 -columnspan 1 -rowspan 1 -sticky ew
grid $site_3_0.02 \
-in $site_3_0 -column 1 -row 0 -columnspan 1 -rowspan 1 -sticky ns
grid $site_3_0.03 \
-in $site_3_0 -column 0 -row 0 -columnspan 1 -rowspan 1 -sticky nesw
frame $base.fra43 \
-borderwidth 2 -height 75 -width 125
vTcl:DefineAlias "$base.fra43" "StatusFrame" vTcl:WidgetProc "Toplevel" 1
set site_3_0 $base.fra43
label $site_3_0.lab44 \
-anchor w -font {Helvetica -12} -relief groove -textvariable status \
-width 70
vTcl:DefineAlias "$site_3_0.lab44" "StatusLabel" vTcl:WidgetProc "Toplevel" 1
label $site_3_0.lab46 \
-font {Helvetica -12} -relief groove -textvariable mode -width 10
vTcl:DefineAlias "$site_3_0.lab46" "ModeLabel" vTcl:WidgetProc "Toplevel" 1
label $site_3_0.lab69 \
-disabledforeground #a1a4a1 -font {Helvetica -12} -relief groove \
-textvariable track -width 4
vTcl:DefineAlias "$site_3_0.lab69" "TrackLabel" vTcl:WidgetProc "Toplevel" 1
pack $site_3_0.lab44 \
-in $site_3_0 -anchor w -expand 1 -fill x -side left
pack $site_3_0.lab46 \
-in $site_3_0 -anchor e -expand 0 -fill none -side right
pack $site_3_0.lab69 \
-in $site_3_0 -anchor center -expand 0 -fill none -side right
###################
# SETTING GEOMETRY
###################
pack $base.cpd35 \
-in $base -anchor center -expand 0 -fill x -side top
pack $base.fra36 \
-in $base -anchor w -expand 0 -fill x -side top
pack $base.cpd37 \
-in $base -anchor w -expand 1 -fill both -side top
grid columnconf $base.cpd37 0 -weight 1
grid rowconf $base.cpd37 0 -weight 1
pack $base.fra43 \
-in $base -anchor w -expand 0 -fill x -side top
vTcl:FireEvent $base <<Ready>>
}
#############################################################################
## Binding tag: all
bind "all" <<PrevWindow>> {
tkTabToWindow [tk_focusPrev %W]
}
bind "all" <Alt-Key> {
tkTraverseToMenu %W %A
}
bind "all" <Control-Key-a> {
q midi_player::start_cb
}
bind "all" <Control-Key-c> {
q midi_player::clear_log_cb
}
bind "all" <Control-Key-e> {
q midi_player::end_cb
}
bind "all" <Control-Key-k> {
q midi_player::new_track_cb
}
bind "all" <Control-Key-n> {
q midi_player::new_cb
}
bind "all" <Control-Key-o> {
q midi_player::open_cb
}
bind "all" <Control-Key-p> {
q midi_player::play_cb
}
bind "all" <Control-Key-q> {
q midi_player::quit_cb
}
bind "all" <Control-Key-r> {
q midi_player::record_cb
}
bind "all" <Control-Key-s> {
q midi_player::save_cb
}
bind "all" <Control-Key-t> {
q midi_player::stop_cb
}
bind "all" <Control-Key-x> {
q midi_player::cancel_cb
}
bind "all" <Key-F10> {
tkFirstMenu %W
}
bind "all" <Key-Tab> {
tkTabToWindow [tk_focusNext %W]
}
bind "all" <Shift-Key-Tab> {
focus [Widget::focusPrev %W]
}
#############################################################################
## Binding tag: _TopLevel
bind "_TopLevel" <<Create>> {
if {![info exists _topcount]} {set _topcount 0}; incr _topcount
}
bind "_TopLevel" <<DeleteWindow>> {
destroy %W; if {$_topcount == 0} {exit}
}
bind "_TopLevel" <Destroy> {
if {[winfo toplevel %W] == "%W"} {incr _topcount -1}
}
#############################################################################
## Binding tag: _vTclBalloon
if {![info exists vTcl(sourcing)]} {
bind "_vTclBalloon" <<KillBalloon>> {
namespace eval ::vTcl::balloon {
after cancel $id
if {[winfo exists .vTcl.balloon]} {
destroy .vTcl.balloon
}
set set 0
}
}
bind "_vTclBalloon" <<vTclBalloon>> {
if {$::vTcl::balloon::first != 1} {break}
namespace eval ::vTcl::balloon {
set first 2
if {![winfo exists .vTcl]} {
toplevel .vTcl; wm withdraw .vTcl
}
if {![winfo exists .vTcl.balloon]} {
toplevel .vTcl.balloon -bg black
}
wm overrideredirect .vTcl.balloon 1
label .vTcl.balloon.l -text ${%W} -relief flat -bg #ffffaa -fg black -padx 2 -pady 0 -anchor w
pack .vTcl.balloon.l -side left -padx 1 -pady 1
wm geometry .vTcl.balloon +[expr {[winfo rootx %W]+[winfo width %W]/2}]+[expr {[winfo rooty %W]+[winfo height %W]+4}]
set set 1
}
}
bind "_vTclBalloon" <Button> {
namespace eval ::vTcl::balloon {
set first 0
}
vTcl:FireEvent %W <<KillBalloon>>
}
bind "_vTclBalloon" <Enter> {
namespace eval ::vTcl::balloon {
## self defining balloon?
if {![info exists %W]} {
vTcl:FireEvent %W <<SetBalloon>>
}
set set 0
set first 1
set id [after 500 {vTcl:FireEvent %W <<vTclBalloon>>}]
}
}
bind "_vTclBalloon" <Leave> {
namespace eval ::vTcl::balloon {
set first 0
}
vTcl:FireEvent %W <<KillBalloon>>
}
bind "_vTclBalloon" <Motion> {
namespace eval ::vTcl::balloon {
if {!$set} {
after cancel $id
set id [after 500 {vTcl:FireEvent %W <<vTclBalloon>>}]
}
}
}
}
Window show .
Window show .top32
main $argc $argv
Index: Makefile.am
===================================================================
RCS file: /cvsroot/q-lang/q-midi/src/Makefile.am,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -C2 -d -r1.1.1.1 -r1.2
*** Makefile.am 15 Dec 2003 11:00:30 -0000 1.1.1.1
--- Makefile.am 5 Jan 2004 19:59:37 -0000 1.2
***************
*** 15,32 ****
stdlibdir = $(pkgdatadir)/lib
! stdlib_DATA = midi.q mididev.q player.q player.tcl
install-data-hook:
sed -e 's?#!/usr/bin/q?#!$(bindir)/q?g' \
! < "$(pkgdatadir)/lib/player.q" \
! > "$(pkgdatadir)/lib/player.sed"
! rm -f "$(pkgdatadir)/lib/player.q"
! mv "$(pkgdatadir)/lib/player.sed" "$(pkgdatadir)/lib/player.q"
! chmod a+x "$(pkgdatadir)/lib/player.q"
! rm -f "$(bindir)/player"
! ln -s "$(pkgdatadir)/lib/player.q" "$(bindir)/player"
uninstall-hook:
! rm -f "$(bindir)/player"
EXTRA_DIST = $(stdlib_DATA) Makefile.msc
--- 15,32 ----
stdlibdir = $(pkgdatadir)/lib
! stdlib_DATA = midi.q mididev.q midi_player.q midi_player.tcl
install-data-hook:
sed -e 's?#!/usr/bin/q?#!$(bindir)/q?g' \
! < "$(pkgdatadir)/lib/midi_player.q" \
! > "$(pkgdatadir)/lib/midi_player.sed"
! rm -f "$(pkgdatadir)/lib/midi_player.q"
! mv "$(pkgdatadir)/lib/midi_player.sed" "$(pkgdatadir)/lib/midi_player.q"
! chmod a+x "$(pkgdatadir)/lib/midi_player.q"
! rm -f "$(bindir)/midi_player"
! ln -s "$(pkgdatadir)/lib/midi_player.q" "$(bindir)/midi_player"
uninstall-hook:
! rm -f "$(bindir)/midi_player"
EXTRA_DIST = $(stdlib_DATA) Makefile.msc
--- player.q DELETED ---
--- player.tcl DELETED ---
|
