This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
yap-6.3/misc/tkyap
2006-02-20 13:18:08 +00:00

486 lines
12 KiB
Tcl

#!/usr/bin/wish -f
# tkyap -- a TK shell for YAP
# $Locker: $
# $Log: not supported by cvs2svn $
# Revision 1.1.1.1 2001/04/09 19:53:46 vsc
# Imported sources
#
# Revision 1.1 1997/06/02 16:32:00 vsc
# Initial revision
#
# Revision 1.1 1994/01/26 17:23:18 rvr
# Luis Damas Version
#
# Created On : Wed Jan 26 17:21:54 1994
# Last Modified By: Nelma Moreira
# Last Modified On: Sat Feb 5 20:24:04 1994
# Update Count : 39
#
# HISTORY
set service 8081
set YapOptions "-h1000 -s1000"
#
set TextFont "*7x13*"
set version "97"
#option add "*text*Font" $TextFont
#option add "*message*Font" $TextFont
#option add "*list*Font" $TextFont
if {[file exists /vmlinuz]} {
set TextFont "*6x10*"
if {[file exists /home/luis/Yap94/linux]} {
set homeyap /home/luis/Yap94/linux
} else {
set homeyap .
}
set PrologCommand "$homeyap/yap $homeyap/startup -c localhost $service $YapOptions"
set SolarisBug 0
} else {
set PrologCommand "ny -h8000 -s1000"
set SolarisBug 1
}
set MaxHistory 100
###############################################################################
# Launch Prolog Proccess
# create server
socket -server client_connection $service
proc client_connection {sock host lixo} {
global from_yap to_yap
set from_yap $sock
set to_yap $sock
puts "Got client $sock $host"
fconfigure $sock -blocking 0 -buffering none
fileevent $sock readable output_from_yap
}
# run yap in parallel
set pid [eval exec $PrologCommand &]
# make sure we kill Prolog when we are killed
# signal trap SIGINT {ExitTkYap}
proc ExitTkYap {} {
global pid
SaveHistory
exec kill $pid
exit
}
###############################################################################
# Create a mininal interface
#### create a terminal window with a scrollbar
frame .frame
text .frame.text -bg white -font $TextFont \
-yscrollcommand {.frame.scrollbarv set}
# insert wellcome message
.frame.text insert end "Welcome to the Tcl/Tk Interface to YAP! ($version)\n"
set iline {\n\n\n\n\n\n} ; # this is because of bug in solaris version
# add scrollbar
frame .frame.scrollframe -relief ridge -bd 2
scrollbar .frame.scrollbarv -command {.frame.text yview}
pack append .frame.scrollframe .frame.scrollbarv {top expand filly}
# pack text widget and scrollbar
pack append .frame \
.frame.text {left frame center expand fill} \
.frame.scrollframe {right frame center filly}
#### Menu ####
frame .menu -relief raised -borderwidth 1
#pack .menu1 -before .frame -side top -fill x
menubutton .menu.file -text "File" -menu .menu.file.m -underline 0
menu .menu.file.m
.menu.file.m add command -label "Consult" -command {ConsultFile} -underline 0
.menu.file.m add command -label "Reconsult" \
-command {ReconsultFile} -underline 0
.menu.file.m add separator
.menu.file.m add command -label "Exit" -command {ExitTkYap} -underline 0
menubutton .menu.exec -text "Execution" -menu .menu.exec.m -underline 0
menu .menu.exec.m
.menu.exec.m add command -label "Interrupt" \
-command {global tcl_mode; set tcl_mode 0; exec kill -SIGINT $pid}
.menu.exec.m add separator
.menu.exec.m add command -label "Statistics" -command {YapStats}
pack .menu.file .menu.exec -side left
menubutton .menu.help -text "Help" -menu .menu.help.m -underline 0
menu .menu.help.m
pack .menu.help -side right
#### pack panes together
pack append . \
.menu {top fillx frame n} \
.frame {left frame n}
proc ReconsultFile {} {
global to_yap
set file [FileSelect "File to Reconsult" "*.yap"]
if {$file!=""} {
puts $to_yap "reconsult('$file')."
flush $to_yap
}
}
proc ConsultFile {} {
global to_yap
set file [FileSelect "File to Consult" "*.yap"]
if {$file!=""} {
puts $to_yap "consult('$file')."
flush $to_yap
}
}
proc YapStats {} {
global to_yap from_yap
puts $to_yap "statistics."
flush $to_yap
}
############################################################################
# Handle input from the keyboard
# InputStart is index of start of input
set InputStart [.frame.text index {end - 1 chars}]
# create a read_only range of text
.frame.text tag add rdonly 0.0 "$InputStart -0 chars"
# prevent user from modifying previous text by jumping to end of text
.frame.text tag bind rdonly <Any-Key> {
if {[.frame.text compare insert < $InputStart]} {
.frame.text mark set insert end
}
}
# pass ^C to yap
bind .frame.text <Control-Key-c> {
set tcl_mode 0
.frame.text yview -pickplace end
exec kill -SIGINT $pid
}
# add Readline/Emacs like bindings
bind .frame.text <Control-Key-a> {
.frame.text mark set insert $InputStart
}
bind .frame.text <Control-Key-b> {
.frame.text mark set insert {insert -1 chars}
}
bind .frame.text <Control-Key-d> {
.frame.text delete insert
}
bind .frame.text <Control-Key-e> {
.frame.text mark set insert end
}
bind .frame.text <Control-Key-f> {
.frame.text mark set insert {insert +1 chars}
}
bind .frame.text <Control-Key-k> {
.frame.text delete insert "insert lineend"
}
bind .frame.text <Key-BackSpace> {
if {[.frame.text compare insert > $InputStart]} {
.frame.text delete "insert -1 chars"
}
}
bind .frame.text <Key-Delete> {
if {[.frame.text compare insert > $InputStart]} {
.frame.text delete "insert -1 chars"
}
}
# add history bindings
set history {}
set history_len 0
set history_dir [exec pwd]
if {[file isfile .yap_history]} {
set file [open "$history_dir/.yap_history"]
while {[gets $file s]>0} {
lappend history $s
incr history_len
}
close $file
}
set history_ind $history_len
proc SaveHistory {} {
global history_len history_ind history history_dir
set file [open "$history_dir/.yap_history" w]
for {set i 0} {$i<$history_len} {incr i} {
puts $file [lindex $history $i]
}
close $file
}
proc AddHistory {line} {
global history_len history_ind history MaxHistory
if {[string length $line]<3} {return}
set i [lsearch -exact $history $line]
if {$i>=0} {
set history [lreplace $history $i $i]
incr history_len -1
}
if {$history_len>$MaxHistory} {
set history [lreplace $history 0 0]
incr history_len -1
}
lappend history $line
incr history_len
set history_ind $history_len
}
bind .frame.text <Control-Key-p> {
if {$history_ind==$history_len} {
set CurrentLine [.frame.text get $InputStart "$InputStart lineend"]
}
if {$history_ind>0} {
incr history_ind -1
.frame.text delete $InputStart "$InputStart lineend"
.frame.text insert $InputStart [lindex $history $history_ind]
}
}
bind .frame.text <Control-Key-n> {
if {$history_ind<$history_len} {
incr history_ind
.frame.text delete $InputStart "$InputStart lineend"
if {$history_ind==$history_len} {
.frame.text insert $InputStart $CurrentLine
} else {
.frame.text insert $InputStart [lindex $history $history_ind]
}
}
}
# catch the enter key and send the input line to yap
bind .frame.text <Key-Return> {HandleInputLine}
proc HandleInputLine {} {
global InputStart to_yap iline
set iline [.frame.text get $InputStart end]
# .frame.text insert end "\n"
AddHistory $iline
puts "sending: '$iline'"
puts -nonewline $to_yap "$iline"
flush $to_yap
set InputStart [.frame.text index end]
.frame.text tag add rdonly 1.0 "$InputStart -0 chars"
}
##############################################################################
# Handle output from Yap
set tcl_mode 0
set tcl_buf {}
proc out_filter {s} {
global tcl_mode tcl_buf InputStart iline SolarisBug
while {$s!=""} {
set i [string first \001 $s]
set j [string first \002 $s]
set xflag 0
if {$j>=0 && ($i==-1 || $j<$i) } {set xflag 1; set i $j}
set new_mode $tcl_mode
if {$i<0} {
set ch $s
set s ""
} else {
set ch [string range $s 0 [expr $i-1]]
set s [string range $s [expr $i+1] end]
if {$xflag==0} { set new_mode [expr 1-$tcl_mode] }
}
# puts "$i $j '$ch' '$s' $xflag"
if {$tcl_mode} {
append tcl_buf $ch
} else {
if {$SolarisBug} {
# under Solaris we get echo on the fisrt line sent to
# Yap. So remove it ...
if {[csubstr $ch 0 [string length $iline]]=="$iline"} {
set ch [string range $ch [string length $iline\r\n] end]
set SolarisBug 0
puts fixed
}
}
.frame.text insert "$InputStart" $ch
set ll [string length $ch]
set InputStart [.frame.text index "$InputStart +$ll chars"]
.frame.text tag add rdonly 1.0 "$InputStart -0 chars"
.frame.text yview -pickplace end
update idletasks
}
if {$xflag} {
puts "eval $tcl_buf"
flush stdout
set res [catch "eval $tcl_buf" errMsg ]
puts "$res $errMsg"
if {$res!=0} {
tkerror $errMsg
}
set tcl_buf {}
}
set tcl_mode $new_mode
}
}
# this is an idle task routine to handle output from yap
proc idle_task {} {
global from_yap
set got 0
while {$got<500} {
set fr [select [list $from_yap] {} {} 0.01]
set fr [lindex $fr 0]
#puts "fr=$fr"
if {$fr != {}} {
#puts "reading"
set ch [read $from_yap ]
incr got [string length $ch]
out_filter $ch
#puts "read '$ch'"
} else {
if {$got} { .frame.text yview -pickplace end }
flush stdout
break
}
}
after 100 idle_task
}
proc output_from_yap {} {
global from_yap
set ch [read $from_yap]
puts "got: '$ch'"
out_filter $ch
.frame.text yview -pickplace end
# fileevent $from_yap readable output_from_yap
update
}
#### File selection...
proc FileSelectOk {} {
global FileSelectRes
set FileSelectRes ok
}
proc FileSelectCancel {} {
global FileSelectRes
set FileSelectRes cancel
}
proc FileSelectUpdate {} {
global FileSelectFilter
set wd [exec pwd]
set dir [open "|ls -a"]
.fileSelect.list delete 0 end
while {[gets $dir f]>0} {
if {[file isdirectory $f]} {
.fileSelect.list insert end $f
} elseif {[string match $FileSelectFilter $f]} {
.fileSelect.list insert end $f
}
}
close $dir
.fileSelect.dir configure -text "Dir: $wd"
}
proc FileSelect {msg filter} {
global FileSelectRes FileSelectFilter
set FileSelectFilter $filter
if {[winfo exists .fileSelect]} {destroy .fileSelect}
toplevel .fileSelect
message .fileSelect.msg -text $msg -width 300
frame .fileSelect.lbox -relief raised -bd 2
listbox .fileSelect.list -bd 1 \
-yscrollcommand {.fileSelect.scroll set}
scrollbar .fileSelect.scroll -bd 2 -command {.fileSelect.list yview}
pack append .fileSelect.lbox \
.fileSelect.list {left expand fill} \
.fileSelect.scroll {right filly}
set wd [exec pwd]
label .fileSelect.dir -text "Directory: $wd "
frame .fileSelect.buttons
button .fileSelect.buttons.ok -text "Ok" -command "FileSelectOk"
button .fileSelect.buttons.cancel -text "Cancel" -command "FileSelectCancel"
pack .fileSelect.buttons.ok .fileSelect.buttons.cancel -side left -padx 10
pack append .fileSelect \
.fileSelect.msg {top expand fillx } \
.fileSelect.dir {expand fillx} \
.fileSelect.lbox {expand fillx} \
.fileSelect.buttons {expand fillx pady 5}
tk_listboxSingleSelect .fileSelect.list
bind .fileSelect.list <Double-ButtonRelease-1> "FileSelectOk"
set w .fileSelect
wm withdraw $w
update idletasks
set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
- [winfo vrootx [winfo parent $w]]]
set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
- [winfo vrooty [winfo parent $w]]]
wm geom $w +$x+$y
wm deiconify $w
set oldFocus [focus]
grab .fileSelect
while 1 {
set FileSelectRes {}
FileSelectUpdate
update
tkwait variable FileSelectRes
if {$FileSelectRes=="cancel"} {break}
set file [.fileSelect.list curselection ]
if {$file!=""} {
set file $wd/[.fileSelect.list get $file]
if {[file isdirectory $file]} {
set wd $file
cd $file
} else {break}
}
}
destroy .fileSelect
focus $oldFocus
if {$FileSelectRes=="cancel"} {
set file ""
cd $wd
}
return $file
}