#!/usr/local/bin/wish

########## CONFIGURATION ###########
global editor
global fontfile
global fontquery
global fonttext

set fontfile "-*-courier-medium-*-normal--*-140-*-*-*-*-*-*"
set fontquery "-*-courier-medium-r-normal--*-140-*-*-*-*-*-*"
set fonttext "-*-courier-medium-r-normal--*-140-*-*-*-*-*-*"
set fontlabel "-*-Helvetica-medium-r-normal--*-180-*-*-p-*-*-*"

set editor  "exec /usr/bin/X11/xterm -rv -T Lygon -e vi %s"

####### SERVER STUFF ########

# Tcl/Tk side of the BinProlog-Tcl/Tk interface
# tested with tcl7.4b2 and tk4.0b2 under Soalris 2.3 on a Sparc 10-20
# uses the new fileevent (addinput-inspired) Tk feature

# USAGE: under the wish tcl/tk shell do:
#
# % start_prolog
# % q {PrologQuery}
# % p {QuietPrologGoal}
# % halt_prolog
#

global f

# tests what Tcl would send to Prolog
proc start_test {} {
  global f
  set f stdout
}

proc halt_slave {f} {
  set fpid [pid $f]
  catch {removeinput $f}
  catch {close $f}
  catch {exec sh -c "kill -9 $fpid"}
  puts "Removed input on $f from process $fpid"
}

proc interrupt_prolog {} {
	global f
	set fpid [pid $f]
	catch {exec sh -c "kill -3 $fpid"}
}
	

# terminates the Prolog process
proc halt_prolog {} {
  global f
  halt_slave $f
}

# connects to a process
proc start_slave {process} {
  global f
  set f [open "|$process" r+]
#  -- use this for older versions patched with addinput
#  addinput $f "bpInOut %% %E %F" 
  fileevent $f readable "bpInOut"
  return $f
}

# connects to a new Prolog process
proc start_prolog {} {
  return [start_slave "bp -h30000 -s10000 -t10000 -c2000 ./lygon.pl"]
}

# writes "Something." to Prolog
proc write_prolog {s} {
  global f
  puts $f $s.
  flush $f
}

# sends to prolog a goal to be quietly evaluated
proc call_prolog {l} {
  write_prolog "call_prolog(($l))"
}

# sends to prolog a query with variables to be answered
#proc query_prolog {l} {
#  write_prolog "query_prolog(($l))"
#}

# shorthand for call_prolog
proc p {l} {
  call_prolog $l
}

# true if there's a tcl call coming from Prolog
proc prolog_is_calling_tcl {l} {
  return [expr 0 == [string first "call_tcl " [string trimleft $l]]]
}

# evaluates a call to tcl from Prolog
proc call_tcl {l} {
  return [eval $l]
}

# detects if an input line contains a tcl call 
# (i.e. when it starts with "call_tcl ")
# if yes then it executes the line
# otherwise it prints it out
proc eval_line {l} {
if {[prolog_is_calling_tcl $l]} {
    call_tcl $l
  } else {
#  puts $l -- uncomment this line to show lines which are ignored by TCL/Tk
  }
}

# spies (in background) on input coming from Prolog
# and passes it to eval_line
# the prolog process should flush the output when doing "nl/0" 

#proc bpInOut {token events fileid} {
#    if {"$events" != "READ"} {
#        error "Unexpected events: $events"
#    } elseif {[gets $fileid line] < 0} {
#        halt_prolog
#    } else {
#       eval_line $line
#    }
#}

proc bpInOut {} {
  global f
# puts "entering bpInOut"
  if {[gets $f line] < 0} {
       halt_prolog
    } else {
       eval_line $line
    }
}

######## GLOBALS ############

global filename
global queryname
global howmany
global v1 v2 v3 v4 v5 v6
global q1 q2 q3 q4 q5 q6

set howmany 1
set filename "test.lyg"
set queryname "untitled.q"

### DEBUGGING ###

global lygonwatch lygonshow
global dowatch doshow dotrace

set dowatch 0
set doshow 0
set dotrace 0

########## PROC DEFINITIONS #########

proc tolist {v} { return "\[[join $v ","]\]" }


proc process {v} {
	set t {}
	foreach i $v {
		set t [linsert $t 1000 "('$i' = $i)"]
	}
	set t "\[[join $t ","]\]"
	return $t
}

proc q1 {q v} {
	setdebug
	if {$v==""} {
		p $q
	} else {
	p "($q) * !(printvars( [process $v] ) * nl ) "
	}
}

proc qn {q v} {
	setdebug
	if {$v==""} {
		p "once( (($q) * !(print(yes) * nl)) @ (print(no) * nl))"
	} else {
	p "($q) * !(printvars([process $v]) * nl * fail)"
	}
}

proc try {q v} {
	global howmany
	if {$q==""} {return}
	if {$howmany==1} {
		q1 $q $v } else {
		qn $q $v }
}

proc loadqueries {} {
    global queryname v1 v2 v3 v4 v5 v6 q1 q2 q3 q4 q5 q6 lygonwatch lygonshow
	set fid [open "$queryname"]
	set q1 [gets $fid]
	set v1 [gets $fid]
	set q2 [gets $fid]
	set v2 [gets $fid]
	set q3 [gets $fid]
	set v3 [gets $fid]
	set q4 [gets $fid]
	set v4 [gets $fid]
	set q5 [gets $fid]
	set v5 [gets $fid]
	set q6 [gets $fid]
	set v6 [gets $fid]
	set lygonshow [gets $fid]
	set lygonwatch [gets $fid]
	close $fid
	setdebug
}

proc savequeries {} {
    global queryname v1 v2 v3 v4 v5 v6 q1 q2 q3 q4 q5 q6 lygonshow lygonwatch
	set fid [open "$queryname" "w" ]
	puts $fid $q1
	puts $fid $v1
	puts $fid $q2
	puts $fid $v2
	puts $fid $q3
	puts $fid $v3
	puts $fid $q4
	puts $fid $v4
	puts $fid $q5
	puts $fid $v5
	puts $fid $q6
	puts $fid $v6
	puts $fid $lygonshow
	puts $fid $lygonwatch
	close $fid
}

proc setwatch {} {
	global dowatch lygonwatch
	if {$dowatch==0} {
		p "setwatch([tolist {}])"
	} else {
		p "setwatch([tolist $lygonwatch])"
	}
	}

proc setshow {} {
	global doshow lygonshow
	if {$doshow==0} {
		p "setshow([tolist {}])"
	} else {
	 	p "setshow([tolist $lygonshow])"
	}
	}

proc settrace {} {
	global dotrace
	if {$dotrace==0} {
		p "traceOff"
	} else {
		p "traceOn"
	}
	}

proc setdebug {} {
	setwatch
	setshow
	settrace
}



### help needs to be extended - also should include debugging help ###

proc help {} {
toplevel .helpw
message .helpw.m -width 15c -justify left -relief raised -bd 2 \
        -font "-*-Helvetica-medium-r-normal--*-180-*-*-p-*-*-*" \
        -text "Not much help at the moment (Sorry!).\n\n\
               Try reading the manual and/or the Lygon WWW page \n\
               (http://www.cs.mu.oz.au/~winikoff/lygon) \n"
button .helpw.b -text Ok -command \
	{.help configure -state normal ; destroy .helpw}
pack .helpw.m .helpw.b
wm title .helpw "Help?"
.help configure -state disabled
}

#proc help {} {
#.output insert end "Not much help at the moment (Sorry!).\n\n\
#	Try reading the manual and/or the Lygon WWW page \n\
#	(http://www.cs.mu.oz.au/~winikoff/lygon) \n\n"
#}

######### FRAMES ##########

frame .top -relief raised -bd 5
frame .middle -relief raised -bd 5
frame .bottom -relief raised -bd 5 
frame .bottom.ff
frame .top.ff

frame .debug -relief raised -bd 5

frame .middle.1 -relief groove -bd 2
frame .middle.2 -relief groove -bd 2
frame .middle.3 -relief groove -bd 2
frame .middle.4 -relief groove -bd 2
frame .middle.5 -relief groove -bd 2
frame .middle.6 -relief groove -bd 2


######### GUI ELEMENTS ########

button .consult -text Consult -command {
	global filename
	p "compile('$filename')"
}

button .edit -text Edit -command {
	global filename
	 set e [format $editor $filename]
	 eval $e
	 p "compile('$filename')"
}

button .open -text "Load" -command {
	global queryname
	loadqueries
}

button .save -text "Save" -command savequeries

button .quit -text Quit -command {exit}
button .help -text Help -command {help}

# Make sure the next line points to the lygon icon ...
button .restart -bitmap @lygon.xbm -command {p "alive"}
# ... or replace it with this line:
#button .restart -text "Lygon 0.7\nPing" -font $fontlabel -command {p "alive"}


checkbutton .fair -text Fair -command {p "fair" }

radiobutton .answerone -text "One" -variable howmany -value 1
radiobutton .answerall -text "All" -variable howmany -value 2
button .stop -text "Interrupt!" -command {interrupt_prolog }

button .clearall -text "Clear all" -command {
	global q1 q2 q3 q4 q5 q6 v1 v2 v3 v4 v5 v6
	set q1 ""
	set q2 ""
	set q3 ""
	set q4 ""
	set q5 ""
	set q6 ""
	set v1 ""
	set v2 ""
	set v3 ""
	set v4 ""
	set v5 ""
	set v6 ""
}

button .doall -text "Do all" -command {
	global q1 q2 q3 q4 q5 q6 v1 v2 v3 v4 v5 v6
	try $q1 $v1
	try $q2 $v2
	try $q3 $v3
	try $q4 $v4
	try $q5 $v5
	try $q6 $v6
}

entry .progname -relief groove -bd 3 -textvariable filename -font $fontfile
entry .queryname -relief groove -bd 3 -textvariable  queryname -font $fontfile
label .labelprog -text "Program: " -font $fontlabel
label .labelquery -text "Queries: " -font $fontlabel

### DEBUG FRAME CONTENTS ###

frame .debug.1 -relief groove -bd 2
frame .debug.2 -relief groove -bd 2
frame .debug.3 -relief groove -bd 2
frame .debug.4 -relief groove -bd 2

label .debugframe -text "Debug: " -font $fontlabel

checkbutton .watchtog -variable dowatch -text \
	"Watch (includes subgoals)" -command setwatch
checkbutton .showtog  -variable doshow -text \
	"Show (no subgoals)" -command setshow
checkbutton .tracetog  -variable dotrace -text \
	"Trace (everything)" -command settrace

label .labelshow -text "Show: " -font $fontlabel
label .labelwatch -text "Watch: " -font $fontlabel
entry .lshow -relief groove -bd 3 -textvariable lygonshow -font $fontfile
entry .lwatch -relief groove -bd 3 -textvariable  lygonwatch -font $fontfile

button .clearshow -text "Clear" -command {set lygonshow {}}
button .clearwatch -text "Clear" -command {set lygonwatch {}}

button .updateshow -text "Update" -command setshow
button .updatewatch -text "Update" -command setwatch

button .step -text "Step ..." -command {p "step"}
button .nextw -text "Next watch" -command {p "towatchf"}
button .debugstop -text "Stop" -command {p "cleanup"}
label .labeldump -text "Show ..." -font $fontlabel
button .lr -text "linear" -command {p "lr"}
button .nlr -text "non-linear" -command {p "nlr"}
button .cls -text "clauses" -command {p "cls"}

### end of debugging widgets ###

entry .query1 -relief sunken -bd 2 -textvariable q1 -font $fontquery
entry .query2 -relief sunken -bd 2 -textvariable q2 -font $fontquery
entry .query3 -relief sunken -bd 2 -textvariable q3 -font $fontquery
entry .query4 -relief sunken -bd 2 -textvariable q4 -font $fontquery
entry .query5 -relief sunken -bd 2 -textvariable q5 -font $fontquery
entry .query6 -relief sunken -bd 2 -textvariable q6 -font $fontquery

entry .vars1 -relief sunken -bd 2 -textvariable v1 -font $fontquery
entry .vars2 -relief sunken -bd 2 -textvariable v2 -font $fontquery
entry .vars3 -relief sunken -bd 2 -textvariable v3 -font $fontquery
entry .vars4 -relief sunken -bd 2 -textvariable v4 -font $fontquery
entry .vars5 -relief sunken -bd 2 -textvariable v5 -font $fontquery
entry .vars6 -relief sunken -bd 2 -textvariable v6 -font $fontquery

button .do1 -text Do -command {try $q1 $v1}
button .do2 -text Do -command {try $q2 $v2}
button .do3 -text Do -command {try $q3 $v3}
button .do4 -text Do -command {try $q4 $v4}
button .do5 -text Do -command {try $q5 $v5}
button .do6 -text Do -command {try $q6 $v6}

button .clear1 -text Clear -command {
	global v1 q1
	set v1 ""
	set q1 ""
}

button .clear2 -text Clear -command {
	global v2 q2
	set v2 ""
	set q2 ""
}

button .clear3 -text Clear -command {
	global v3 q3
	set v3 ""
	set q3 ""
}

button .clear4 -text Clear -command {
	global v4 q4
	set v4 ""
	set q4 ""
}

button .clear5 -text Clear -command {
	global v5 q5
	set v5 ""
	set q5 ""
}

button .clear6 -text Clear -command {
	global v6 q6
	set v6 ""
	set q6 ""
}


label .results -text "Results" -font $fontlabel
button .cleares -text "Clear output" -command {.output delete 1.0 end}

text  .output -relief raised -bd 2 -yscrollcommand ".scroll set" -font $fonttext
scrollbar .scroll -command ".output yview"

######### PACKING #########

pack .top -side top  -fill x
pack .middle -side top  -fill x
pack .debug -side top -fill x 
pack .bottom -side top -fill x -expand 1

pack .restart -side left -expand 0 -in .top

pack .bottom.ff -side top -fill x -in .bottom -expand 1
pack .top.ff -side bottom -fill x -in .top 

pack .middle.1 -side top -fill x -in .middle
pack .middle.2 -side top -fill x -in .middle
pack .middle.3 -side top -fill x -in .middle
pack .middle.4 -side top -fill x -in .middle
pack .middle.5 -side top -fill x -in .middle
pack .middle.6 -side top -fill x -in .middle


pack .labelprog .progname .labelquery .queryname  \
	-side left -in .top.ff -expand 1 -fill x
pack .consult .edit .open .save .help .quit -in .top -side \
	left -fill both -expand 1

pack .output -side left -fill both -in .bottom -expand 1
pack .scroll -side right -fill y  -in .bottom -expand 1

pack .results -side left -in .bottom.ff
pack .cleares -side right -fill x -in .bottom.ff -expand 1
pack .clearall -side right -fill x -in .bottom.ff -expand 1
pack .doall -side right -fill x -in .bottom.ff -expand 1
pack  .answerone .answerall .fair .stop -in .bottom.ff -side left -fill both -expand 1


pack .query1 -side left -fill both -in .middle.1 -ipadx 10m -expand 1
pack .query2 -side left -fill both -in .middle.2 -ipadx 10m -expand 1
pack .query3 -side left -fill both -in .middle.3 -ipadx 10m -expand 1
pack .query4 -side left -fill both -in .middle.4 -ipadx 10m -expand 1
pack .query5 -side left -fill both -in .middle.5 -ipadx 10m -expand 1
pack .query6 -side left -fill both -in .middle.6 -ipadx 10m -expand 1


pack .vars1 -side left -fill both -in .middle.1 -ipadx 5m -expand 1
pack .vars2 -side left -fill both -in .middle.2 -ipadx 5m -expand 1
pack .vars3 -side left -fill both -in .middle.3 -ipadx 5m -expand 1
pack .vars4 -side left -fill both -in .middle.4 -ipadx 5m -expand 1
pack .vars5 -side left -fill both -in .middle.5 -ipadx 5m -expand 1
pack .vars6 -side left -fill both -in .middle.6 -ipadx 5m -expand 1


pack .do1 -side left -fill x -in .middle.1 -expand 1
pack .do2 -side left -fill x -in .middle.2 -expand 1
pack .do3 -side left -fill x -in .middle.3 -expand 1
pack .do4 -side left -fill x -in .middle.4 -expand 1
pack .do5 -side left -fill x -in .middle.5 -expand 1
pack .do6 -side left -fill x -in .middle.6 -expand 1

pack .clear1 -side left -fill x -in .middle.1 -expand 1
pack .clear2 -side left -fill x -in .middle.2 -expand 1
pack .clear3 -side left -fill x -in .middle.3 -expand 1
pack .clear4 -side left -fill x -in .middle.4 -expand 1
pack .clear5 -side left -fill x -in .middle.5 -expand 1
pack .clear6 -side left -fill x -in .middle.6 -expand 1

pack .debug.1 -side top -fill x -in .debug
pack .debug.2 -side top -fill x -in .debug
pack .debug.3 -side top -fill x -in .debug
pack .debug.4 -side top -fill x -in .debug

pack .debugframe -in .debug.1 -side left
pack .watchtog .showtog .tracetog -side left -fill both -in .debug.1 -expand 1

pack .labelshow -side left -in .debug.2 
pack .lshow  -side left -in .debug.2 -expand 1 -fill x
pack .clearshow .updateshow -side left -in .debug.2 

pack .labelwatch -side left -in .debug.3
pack .lwatch -side left -in .debug.3 -expand 1 -fill x
pack .clearwatch .updatewatch -side left -in .debug.3 

pack .step .nextw .debugstop .labeldump .lr .nlr .cls \
	 -side left -fill x -in .debug.4 -expand 1


########## INITIALISE SYSTEM ########

set q1 "query"
set v1 "variables"

wm title . "Lygon"

if {$argc == 1} {
	set filename $argv
}

start_prolog
#start_test 
#- replace prev with this to see what TCL/Tk is sending to Prolog


p "gui"

p "compile('$filename')"

