#!/usr/local/bin/wishm -f
# Copyright (c) 1993 Michael B. Durian.  All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. All advertising materials mentioning features or use of this software
#    must display the following acknowledgement:
#	This product includes software developed by Michael B. Durian.
# 4. The name of the the Author may be used to endorse or promote 
#    products derived from this software without specific prior written 
#    permission.
#
# THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED 
# WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
# OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.  
# IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.

# xdrum,v 1.8 1993/05/05 01:35:25 durian Exp

set InputValue {}
set InputValid {}
set InputIndex {}

set Division 120
set Tempo 120
set Channel 0
set BaseFileName xdrum

set PlayPID -1
set PlayMFile {}

wm maxsize . 1024 1024
drumgrid .dg -xscrollcommand {.xscroll set} -yscrollcommand {.yscroll set}
scrollbar .xscroll -command {ChangePosition} -orient horizontal
scrollbar .yscroll -command {.dg yview} -orient vertical
frame .buttons
menubutton .buttons.config -text "Adjust Grid" -menu .buttons.config.menu \
    -relief raised
menu .buttons.config.menu
.buttons.config.menu add command -label "Add Voice" -command AddVoice
.buttons.config.menu add command -label "Remove Voice" -command RemoveVoice
.buttons.config.menu add command -label "Change Pitch" -command ChangePitch
.buttons.config.menu add command -label "Change Tempo" -command ChangeTempo
.buttons.config.menu add command -label "Change Division" \
    -command ChangeDivision
.buttons.config.menu add command -label "Change Channel" -command ChangeChannel
.buttons.config.menu add separator
.buttons.config.menu add command -label "Change Beats" -command ChangeBeats
.buttons.config.menu add command -label "Change Measures" \
    -command ChangeMeasures
.buttons.config.menu add command -label "Change Quantization" \
    -command ChangeQuant
.buttons.config.menu add command -label "Change Levels" -command ChangeLevels
menubutton .buttons.file -text "File I/O" -menu .buttons.file.menu \
    -relief raised
menu .buttons.file.menu
.buttons.file.menu add command -label "Save ASCII" -command SaveASCII
.buttons.file.menu add command -label "Load ASCII" -command LoadASCII
.buttons.file.menu add command -label "Save MIDI" -command SaveMIDI
if {[midiplayable]} {
	menubutton .buttons.play -text "Play" -menu .buttons.play.menu \
	    -relief raised
	menu .buttons.play.menu
	.buttons.play.menu add command -label "Play Pattern" \
	    -command PlayPattern
	.buttons.play.menu add command -label "Stop Playing" \
	    -command StopPlaying
}
button .buttons.quit -text "Quit" -command {StopPlaying; destroy .}
label .position
pack append .buttons \
    .buttons.config {left expand} \
    .buttons.file {left expand} \
    .buttons.quit {left expand}
pack append . \
    .buttons {bottom fillx} \
    .position {top fillx} \
    .yscroll {right filly} \
    .xscroll {bottom fillx} \
    .dg {top fill expand}

if {[midiplayable]} {
	pack before .buttons.quit .buttons.play {left expand}
}

proc AddVoice {} {
	global InputValue
	global InputValid

	set pos [split [wm geometry .] +]
	set x [expr {[lindex $pos 1] + 20}]
	set y [expr {[lindex $pos 2] + 20}]
	
	tkwait window [GetText $x $y "New Voice:" ""]
	if {$InputValid} {
		.dg label add $InputValue
	}
}

proc RemoveVoice {} {
	global InputValue
	global InputValid

	set pos [split [wm geometry .] +]
	set x [expr {[lindex $pos 1] + 20}]
	set y [expr {[lindex $pos 2] + 20}]
	
	tkwait window [GetSelection $x $y "Which Voice:" [.dg label list]]
	if {$InputValid} {
		.dg label remove label [lindex $InputValue 0]
	}
}

proc ChangePitch {} {
	global InputValue
	global InputValid
	global InputIndex

	set pos [split [wm geometry .] +]
	set x [expr {[lindex $pos 1] + 20}]
	set y [expr {[lindex $pos 2] + 20}]

	tkwait window [GetSelection $x $y "Which Voice:" [.dg label list]]
	if {!$InputValid} {
		return
	}
	set pitch [.dg pitch get $InputIndex]

	tkwait window [GetText $x $y "Pitch:" $pitch]
	if {$InputValid} {
		.dg pitch set $InputIndex $InputValue
	}
}

proc ChangeTempo {} {
	global InputValue
	global InputValid
	global Tempo

	set pos [split [wm geometry .] +]
	set x [expr {[lindex $pos 1] + 20}]
	set y [expr {[lindex $pos 2] + 20}]
	
	tkwait window [GetText $x $y "New Tempo:" $Tempo]
	if {$InputValid} {
		set Tempo $InputValue
	}
}

proc ChangeDivision {} {
	global InputValue
	global InputValid
	global Division

	set pos [split [wm geometry .] +]
	set x [expr {[lindex $pos 1] + 20}]
	set y [expr {[lindex $pos 2] + 20}]
	
	tkwait window [GetText $x $y "New Division:" $Division]
	if {$InputValid} {
		set Division $InputValue
	}
}

proc ChangeChannel {} {
	global InputValue
	global InputValid
	global Channel

	set pos [split [wm geometry .] +]
	set x [expr {[lindex $pos 1] + 20}]
	set y [expr {[lindex $pos 2] + 20}]
	
	tkwait window [GetText $x $y "New Channel:" $Channel]
	if {$InputValid} {
		set Channel $InputValue
	}
}

proc ChangeBeats {} {
	global InputValue
	global InputValid
	global InputIndex

	set pos [split [wm geometry .] +]
	set x [expr {[lindex $pos 1] + 20}]
	set y [expr {[lindex $pos 2] + 20}]

	tkwait window [GetText $x $y "Beats Per Measure:" \
	    [lindex [.dg configure -beats] 4]]
	if {$InputValid} {
		.dg configure -beats $InputValue
		ChangePositionLabel [.dg xview]
	}
}

proc ChangeMeasures {} {
	global InputValue
	global InputValid
	global InputIndex

	set pos [split [wm geometry .] +]
	set x [expr {[lindex $pos 1] + 20}]
	set y [expr {[lindex $pos 2] + 20}]

	tkwait window [GetText $x $y "Number of Measures:" \
	    [lindex [.dg configure -measures] 4]]
	if {$InputValid} {
		.dg configure -measures $InputValue
		ChangePositionLabel [.dg xview]
	}
}

proc ChangeQuant {} {
	global InputValue
	global InputValid
	global InputIndex

	set pos [split [wm geometry .] +]
	set x [expr {[lindex $pos 1] + 20}]
	set y [expr {[lindex $pos 2] + 20}]

	tkwait window [GetText $x $y "New Quantization (mult. of 4):" \
	    [lindex [.dg configure -quantization] 4]]
	if {$InputValid} {
		.dg configure -quantization $InputValue
		ChangePositionLabel [.dg xview]
	}
}

proc ChangeLevels {} {
	global InputValue
	global InputValid
	global InputIndex

	set pos [split [wm geometry .] +]
	set x [expr {[lindex $pos 1] + 20}]
	set y [expr {[lindex $pos 2] + 20}]

	tkwait window [GetText $x $y "New Levels of Dynamics:" \
	    [lindex [.dg configure -levels] 4]]
	if {$InputValid} {
		.dg configure -levels $InputValue
		ChangePositionLabel [.dg xview]
	}
}

proc SaveASCII {} {
	global InputValue
	global InputValid
	global InputIndex
	global BaseFileName
	global Tempo
	global Division
	global Channel

	set pos [split [wm geometry .] +]
	set x [expr {[lindex $pos 1] + 20}]
	set y [expr {[lindex $pos 2] + 20}]

	tkwait window [GetText $x $y "File Name:" ${BaseFileName}.ptrn]
	if {!$InputValid} {
		return
	}

	set BaseFileName [join [lrange [split $InputValue .] \
	    0 [expr {[llength $InputValue] - 1}]] .]

	ChangePositionLabel [.dg xview]

	if {[file exists $InputValue] && ! [file writable $InputValue]} {
		tkwait window [PutMessage $x $y \
		    "$InputValue exists and is not writable."]
		return
	}

	set file [open $InputValue "w"]
	puts $file "xdrum pattern $InputValue"
	puts $file "Measures:"
	puts $file "[lindex [.dg configure -measures] 4]"
	puts $file "Beats:"
	puts $file "[lindex [.dg configure -beats] 4]"
	puts $file "Quantization:"
	puts $file "[lindex [.dg configure -quantization] 4]"
	puts $file "Levels:"
	puts $file "[lindex [.dg configure -levels] 4]"
	puts $file "Tempo:"
	puts $file "$Tempo"
	puts $file "Division:"
	puts $file "$Division"
	puts $file "Channel:"
	puts $file "$Channel"
	set labels [.dg label list]
	set num_labels [llength $labels]
	puts $file "Number Labels:"
	puts $file "$num_labels"
	puts $file "Labels:"
	foreach label $labels {
		puts $file $label
	}
	puts $file "Pitches:"
	for {set i 0} {$i < $num_labels} {incr i} {
		puts $file [.dg pitch get $i]
	}
	puts $file "Volumes:"
	foreach column [.dg volume get all] {
		puts $file $column
	}
	close $file
}

proc LoadASCII {} {
	global InputValue
	global InputValid
	global InputIndex
	global BaseFileName
	global Tempo
	global Division
	global Channel

	set pos [split [wm geometry .] +]
	set x [expr {[lindex $pos 1] + 20}]
	set y [expr {[lindex $pos 2] + 20}]

	tkwait window [GetText $x $y "File Name:" ${BaseFileName}.ptrn]
	if {!$InputValid} {
		return
	}

	set BaseFileName [join [lrange [split $InputValue .] \
	    0 [expr {[llength $InputValue] - 1}]] .]

	ChangePositionLabel [.dg xview]
	
	if {! ([file exists $InputValue] && [file readable $InputValue])} {
		tkwait window [PutMessage $x $y \
		    "$InputValue does not exist or is not readable."]
		return
	}
	set file [open $InputValue "r"]
	if { ! [string match "xdrum pattern*" [gets $file]] } {
		tkwait window [PutMessage $x $y \
		    "$InputValue is not a valid xdrum ASCII pattern file."]
		return
	}
	# Measures:
	gets $file
	set measures [gets $file]
	# Beats:
	gets $file
	set beats [gets $file]
	# Quantization:
	gets $file
	set quant [gets $file]
	# Levels:
	gets $file
	set levels [gets $file]
	# Tempo:
	gets $file
	set Tempo [gets $file]
	# Division
	gets $file
	set Division [gets $file]
	# Channel
	gets $file
	set Channel [gets $file]
	# Number labels:
	gets $file
	set num_labels [gets $file]
	# Labels:
	gets $file
	for {set i 0} {$i < $num_labels} {incr i} {
		lappend labels [gets $file]
	}
	# Pitches:
	gets $file
	for {set i 0} {$i < $num_labels} {incr i} {
		lappend pitches [gets $file]
	}
	# Volumes:
	gets $file
	set num_hits [expr {$measures * $beats * $quant / 4}]
	for {set i 0} {$i < $num_hits} {incr i} {
		lappend volumes [gets $file]
	}
	close $file

	.dg configure -measures $measures
	.dg configure -beats $beats
	.dg configure -quantization $quant
	.dg configure -levels $levels
	.dg configure -labels $labels
	.dg configure -pitches $pitches
	set x 0
	foreach column $volumes {
		set y 0
		foreach voice $column {
			.dg volume set $x $y $voice
			incr y
		}
		incr x
	}
}

proc GenerateSMF {pattern_name} {
	global Tempo
	global Division
	global Channel

	# some values we'll need
	set beats [lindex [.dg configure -beats] 4]
	set measures [lindex [.dg configure -measures] 4]
	set quant [lindex [.dg configure -quantization] 4]
	set levels [lindex [.dg configure -levels] 4]

	set mfile [midimake]
	midiconfig $mfile format 1
	midiconfig $mfile division $Division
	midiconfig $mfile tracks 2

	# give a seqence name
	midiput $mfile 0 0 metaseqname $pattern_name

	# set the tempo
	midiput $mfile 0 0 metatempo $Tempo

	# time signature
	midiput $mfile 0 0 metatime 4 4 24 8

	# now put an EOT at the end - with proper delta
	set elapsed [expr {$Division * $beats * $measures}]
	midiput $mfile 0 $elapsed metaeot

	# now the real events
	set events [.dg volume get all]
	set pitches [.dg pitch list]
	set num_voices [llength $pitches]

	set time_delta [expr {$Division * 4 / $quant}]

	set delta 0
	set no_status 1
	foreach time_slice $events {
		set notes_on ""
		# do notes on
		for {set i 0} {$i < $num_voices} {incr i} {
			set voice [lindex $time_slice $i]
			if {$voice != 0} {
				set p [lindex $pitches $i]
				midiput $mfile 1 $delta noteon $Channel $p \
				    [expr {127 * $voice / ($levels - 1)}]
				# keep track off pitches that need to go
				# off
				lappend notes_on $p
				# clear delta
				set delta 0
			}
		}
		incr delta $time_delta

		# do notes off if needed
		if {[llength $notes_on] > 0} {
			foreach p $notes_on {
				midiput $mfile 1 $delta noteoff $Channel $p
				# clear delta
				set delta 0
			}
		}
	}
	# EOT for track 1
	midiput $mfile 1 $delta metaeot

	return $mfile
}

proc SaveMIDI {} {
	global InputValue
	global InputValid
	global InputIndex
	global BaseFileName

	set pos [split [wm geometry .] +]
	set x [expr {[lindex $pos 1] + 20}]
	set y [expr {[lindex $pos 2] + 20}]

	tkwait window [GetText $x $y "File Name:" ${BaseFileName}.mid]
	if {!$InputValid} {
		return
	}

	set BaseFileName [join [lrange [split $InputValue .] \
	    0 [expr {[llength $InputValue] - 1}]] .]

	ChangePositionLabel [.dg xview]

	if {[file exists $InputValue] && ! [file writable $InputValue]} {
		tkwait window [PutMessage $x $y \
		    "$InputValue exists and is not writable."]
		return
	}

	# now let's write this puppy
	set file [open $InputValue "w"]
	set mfile [GenerateSMF $InputValue]
	midiwrite $mfile $file
	close $file
	midifree $mfile
}

proc PlayPattern {} {
	global PlayPID
	global PlayMFile

	set mfile [GenerateSMF internal]
	set PlayPID [midiplay background repeat $mfile]
	set PlayMFile $mfile
}

proc StopPlaying {} {
	global PlayPID
	global PlayMFile

	if {$PlayPID != -1} {
		midistop $PlayPID
		midifree $PlayMFile
		set PlayPID -1
	}
}


proc ChangePositionLabel {hit} {
	global BaseFileName

	set quant [lindex [.dg configure -quantization] 4]
	set measure [expr {$hit / $quant}]
	set remain [expr {$hit % $quant}]
	set hit_per_beat [expr {$quant / 4}]
	set beat [expr {$remain / $hit_per_beat}]
	set q [expr {$remain % $hit_per_beat}]

	.position configure -text \
	    "$BaseFileName - Measure:$measure Beat:$beat Quant:$q/$hit_per_beat"
}

proc ChangePosition {hit} {

	.dg xview $hit
	ChangePositionLabel [.dg xview]
}


proc GetText {x y prompt default} {
	global InputValue
	global InputValid

	toplevel .get_text
	wm transient .get_text .
	wm geometry .get_text "+$x+$y"
	grab .get_text

	set InputValid 0

	label .get_text.label -text "$prompt"
	entry .get_text.entry
	.get_text.entry insert 0 "$default"
	bind .get_text.entry <Return> {set InputValue [.get_text.entry get]; \
	    set InputValid 1; destroy .get_text}
	button .get_text.ok -text "OK" -command {set InputValue \
	    [.get_text.entry get]; set InputValid 1; destroy .get_text}
	button .get_text.cancel -text "Cancel" -command {destroy .get_text}

	focus .get_text.entry

	pack append .get_text \
	    .get_text.label {top fill} \
	    .get_text.entry {top fill} \
	    .get_text.ok {left fill expand} \
	    .get_text.cancel {left fill expand}
	return ".get_text"
}

proc GetSelection {x y prompt list} {
	global InputValue
	global InputValid

	toplevel .get_sel
	wm transient .get_sel .
	wm geometry .get_sel "+$x+$y"
	grab .get_sel

	set InputValid 0
	set InputIndex 0

	label .get_sel.label -text "$prompt"
	listbox .get_sel.list -yscrollcommand {.get_sel.scrolly set}
	foreach elem $list {
		.get_sel.list insert end $elem
	}
	tk_listboxSingleSelect .get_sel.list
	button .get_sel.cancel -text "Cancel" -command {destroy .get_sel}
	scrollbar .get_sel.scrolly -command {.get_sel.list yview}

	bind .get_sel.list <ButtonRelease-1> {set InputValue [selection get]; \
	    set InputValid 1; \
	    set InputIndex [.get_sel.list curselection]; \
	    destroy .get_sel}

	pack append .get_sel \
		.get_sel.label {top fill} \
		.get_sel.cancel {bottom fill} \
		.get_sel.scrolly {right filly} \
		.get_sel.list {top fill expand}

	return .get_sel
}

proc PutMessage {x y message} {

	toplevel .put_message
	wm transient .put_message .
	wm geometry .put_message "+$x+$y"
	grab .put_message

	label .put_message.message -text "$message"
	button .put_message.ok -text "OK" -command {destroy .put_message}

	pack append .put_message \
	    .put_message.message {top fill expand} \
	    .put_message.ok {bottom fill}
	return ".put_message"
}

proc StrToHex {str} {

	foreach char [split $str {}] {
		scan $char %c dec
		lappend hex_str [format 0x%x $dec]
	}

	return $hex_str
}

ChangePositionLabel 0
