%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%                                                                      %%
%%  Help                                                                %%
%%                                                                      %%
%%  (c) 2000 Université catholique de Louvain.  All Rights Reserved.    %%
%%  The development of this software is supported by the PIRATES        %%
%%  project at the Université catholique de Louvain.  This file is      %%
%%  subject to the general Mozart license.                              %%
%%                                                                      %%
%%  Author: Donatien Grolaux                                            %%
%%                                                                      %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

functor

import 
   Pickle
   Open
   Compiler
   System(show:Show)
   Tree(treeNode:TreeNode) at 'http://www.info.ucl.ac.be/people/ned/tree/Tree.ozf'
   Regex at 'x-oz://contrib/regex'
   BrowserControl at 'x-ozuser://franzen/BrowserControl.ozf'
   Tk
   QTk at 'http://www.info.ucl.ac.be/people/ned/qtk/QTk.ozf'
   
export
   HelpClass
   DefaultBind
   Hyperlink

define

   NoArgs={NewName}
   
   class Hyperlink

      feat
	 Dict Fmt
	 normal
	 bold
	 italic
	 bolditalic
	 
      meth init
	 if {IsFree self.Dict} then
	    self.Dict={NewDictionary}
	    self.Fmt={NewDictionary}
	    self.normal={New Tk.font tkInit(family:times size:10)}
	    self.bold={New Tk.font tkInit(family:times size:10 weight:bold)}
	    self.italic={New Tk.font tkInit(family:times size:10 slant:italic)}
	    self.bolditalic={New Tk.font tkInit(family:times size:10 weight:bold slant:italic)}
	 else
	    {self reinit}
	 end
      end

      meth reinit
	 {ForAll {self keys($)}
	  proc{$ K} {self remove(K)} end}
	 {ForAll {Dictionary.keys self.Fmt}
	  proc{$ K} {Dictionary.remove self.Fmt K} end}
	 {self.normal set(family:times size:10)}
	 {self.bold set(family:times size:10 weight:bold)}
	 {self.italic set(family:times size:10 slant:italic)}
	 {self.bolditalic set(family:times size:10 weight:bold slant:italic)}
      end
      
      meth put(K D)
	 {Dictionary.put self.Dict K D}
      end
      
      meth get(K $)
	 {Dictionary.condGet self.Dict K ["No help available on this topic"]}
      end

      meth remove(K)
	 {Dictionary.remove self.Dict K}
      end

      meth entries($)
	 {Dictionary.entries self.Dict $}
      end

      meth keys($)
	 {Dictionary.keys self.Dict $}
      end

      meth items($)
	 {Dictionary.items self.Dict $}
      end
 
      meth parseText(Txt $)
	 fun{Loop1 L}
	    case L
	    of &<|&<|_ then
	       Xs
	    in
	       {Loop2 L Xs}|{Loop1 Xs}
	    [] &<|Rs then
	       Xs
	    in
	       {Loop3 Rs Xs}|{Loop1 Xs}
	    [] nil then
	       nil
	    else
	       Xs
	    in
	       {Loop2 L Xs}|{Loop1 Xs}
	    end
	 end
	 fun{Loop2 L R}
	    case L
	    of &<|&<|Xs then
	       &<|{Loop2 Xs R}
	    [] &<|_ then
	       R=L
	       nil
	    [] X|Xs then
	       X|{Loop2 Xs R}
	    else
	       R=nil
	       nil
	    end
	 end
	 fun{Loop3 L R}
	    fun{LoopA L R} % obtain the parameter name
	       case L
	       of &>|_ then
		  R=L
		  nil
	       [] &||_ then
		  R=L
		  nil
	       [] nil then
		  R=nil
		  nil
	       [] X|Xs then
		  X|{LoopA Xs R}
	       end
	    end
	    Label
	    fun{LoopB I L R} % obtain the parameter name
	       case L
	       of &>|Xs then
		  R=Xs
		  nil
	       [] &||Xs then
		  Xss
	       in
		  I#{LoopA Xs Xss}|{LoopB I+1 Xss R}
	       else
		  R=Xs
		  nil
	       end
	    end
	    Xs
	 in
	    Label={VirtualString.toAtom {LoopA L Xs}}
	    {List.toRecord Label {LoopB 1 Xs R}}
	 end
      in
	 {Loop1 Txt}
      end

      meth putText(K Txt)
	 {self put(K {self parseText(Txt $)})}
      end
     
      meth parseHelpFile(Filename)
	 F={New Open.file init(name:Filename)}
	 Data={F read(size:all list:$)}
	 {F close}
	 proc{Loop1 L}
	    case L
	    of &\n|Xs then {Loop1 Xs} %% skips firsts \n
	    [] nil then skip
	    else
	       Rs Rss
	    in
	       {self putText({String.toAtom {Loop2 L Rs}}
			     {Loop3 Rs Rss})}
	       {Loop1 Rss}
	    end
	 end
	 fun{Loop2 L R}
	    case L
	    of &\n|Xs then
	       R=Xs
	       nil
	    [] nil then
	       R=nil
	       nil
	    [] X|Xs then
	       X|{Loop2 Xs R}
	    end
	 end
	 fun{Loop3 L R}
	    case L
	    of &\n|&\n|Xs then
	       R=Xs
	       nil
	    [] nil then
	       R=nil
	       nil
	    [] X|Xs then
	       X|{Loop3 Xs R}
	    end
	 end
      in
	 %% cut read Data
	 {Loop1 Data}
      end

      meth saveHelpFile(Filename)
	 {Pickle.save Filename {self entries($)}}
      end

      meth loadHelpFile(Filename)
	 L={Pickle.load Filename}
      in
	 {ForAll L
	  proc{$ E}
	     K#V=E
	  in
	     {self put(K V)}
	  end}
      end

      meth setFormat(T F)
	 %% T is the tag name like 'bold'
	 {Dictionary.put self.Fmt T F}
	 %% format currently supported of F is :
	 %% alone(cmd:Proc/1)
	 %% on(cmd:Proc/1
	 %%    off:T)
	 %% off(cmd:Proc/1
	 %%     on:T)
      end

      meth getFormat(T $)
	 {Dictionary.get self.Fmt T}
      end

      meth fillEntry(K T id:ID<=NoArgs)
	 Data={self get(K $)}
	 TS={NewDictionary}
	 TagList={NewCell nil}
	 TagCode={NewCell q}
	 proc{CalcTagCode}
	    {Assign TagCode
	     {List.toRecord q
	      {List.mapInd {Access TagList}
	       fun{$ I T} I#T end}}}
	 end
	 proc{Push K}
	    %% push a parameter : associate it with a tag
	    Tag={T newTag($)}
	 in
	    {Assign TagList Tag|{Access TagList}}
	    {Dictionary.put TS K
	     Tag|{Dictionary.condGet TS K nil}}
	    {CalcTagCode}
	 end
	 fun{Pop K}
	    %% pop a parameter : get its tag back and removes it from where it has to be removed
	    TL={Dictionary.condGet TS K [unit]}
	    Tag={List.nth TL 1}
	 in
	    if Tag\=unit then
	       {Assign TagList {List.subtract {Access TagList} Tag}}
	       {Dictionary.put TS K
		{List.drop TL 1}}
	       {CalcTagCode}
	    end
	    Tag
	 end
	 proc{Loop L}
	    case L
	    of X|Xs then
	       if {String.is X} then
		  {T insert('end' X {Access TagCode})}
	       else
		  Code={Label X}
		  Action={Dictionary.condGet self.Fmt Code alone}
		  proc{Exec Init}
		     if {HasFeature Action cmd} then
			{Action.cmd {Record.adjoin
				     r(widget:T
				       toplevel:T.toplevel
				       id:ID
				       ctags:{Access TagCode}
				       setctags:proc{$ Start End}
						   {Record.forAll {Access TagCode}
						    proc{$ Tag}
						       {T tk(tag add Tag Start.1#"."#Start.2 End)}
%						       {T add(Start End)}
						    end}
						end

				      )
				     {Record.adjoin
				      Init
				      X}}}
		     end
		  end
	       in
		  case {Label Action}
		  of alone then
		     {Exec r}
		  [] on then
		     {Push Code}
		     {Exec r}
		  [] off then
		     Tag={Pop Action.on}
		  in
		     if Tag\=unit then
			{Exec r(tag:Tag)}
		     end
		  end
	       end
	       {Loop Xs}
	    [] nil then skip
	    end
	 end
      in
	 {Loop Data}
      end
      
      meth getQTk(K id:ID<=NoArgs thid:THID<=_ $)
	 T
	 thread
	    THID={Thread.this}
	    {Wait T}
	    try
	       {self fillEntry(K T id:ID)}
	    catch _ then skip end %% ignore if any error, just terminate
	    try
	       {T set(state:disabled)} %% ignore if any error
	    catch _ then skip end
	 end
      in
	 text(handle:T
	      glue:nswe
	      bg:white
	      font:self.normal
	      wrap:word
	      tdscrollbar:true)
      end
      
      meth getText(K $)
	 {List.flatten
	  {List.filter
	   {self get(K $)}
	   String.is}}
      end
      
   end

   proc{DefaultBind H}
      {ForAll
       [b#on %% bold
	'/b'#off(on:b
		 cmd:proc{$ P}
			{P.tag set(font:H.bold)}
		     end)
	i#on %% italic
	'/i'#off(on:i
		 cmd:proc{$ P}
			{P.tag set(font:H.italic)}
		     end)
	bi#on %% bold italic
	'/bi'#off(on:bi
		  cmd:proc{$ P}
			 {P.tag set(font:H.bolditalic)}
		      end)
	u#on %% underline
	'/u'#off(on:u
		 cmd:proc{$ P}
			{P.tag set(underline:true)}
		     end)
	o#on %% overstrike
	'/o'#off(on:o
		 cmd:proc{$ P}
			{P.tag set(overstrike:true)}
		     end)
	f#on %% change font
	'/f'#off(on:f
		 cmd:proc{$ P}
			{P.tag set(font:P.1)}
		     end)
	p#alone(cmd:proc{$ P} %% paragraph jump
		       {P.widget insert('end' "\n")}
		    end)
	left#on %% left justified
	'/left'#off(on:left
		    cmd:proc{$ P} {P.tag set(justify:left)} end)
	right#on %% right justified
	'/right'#off(on:right
		     cmd:proc{$ P} {P.tag set(justify:right)} end)
	center#on %% center justified
	'/center'#off(on:center
		      cmd:proc{$ P} {P.tag set(justify:center)} end)
	fg#on %% 
	'/fg'#off(on:fg
		  cmd:proc{$ P} {P.tag set(foreground:{String.toAtom P.1})} end)
	bg#on
	'/bg'#off(on:bg
		  cmd:proc{$ P} {P.tag set(background:{String.toAtom P.1})} end)
	bitmap#alone(cmd:proc{$ P}
			    {P.widget newWindow('end'
						label(bitmap:P.1) _)}
			 end)
	blink#on
	'/blink'#off(on:blink
		     cmd:proc{$ P}
			    proc{Loop}
			       try
				  {P.tag set(foreground:{P.widget get(foreground:$)})}
				  {Delay 500}
				  {P.tag set(foreground:{P.widget get(background:$)})}
				  {Delay 500}
				  {Loop}
			       catch _ then skip end
			    end
			    ID
			 in
			    thread
			       ID={Thread.this}
			       {Loop}
			    end
			    thread
			       {P.toplevel wait}
			       try
				  {Thread.terminate ID}
			       catch _ then skip end
			    end
			 end)
	background#alone(cmd:proc{$ P}
				{P.widget set(background:{String.toAtom P.1})}
			     end)
	foreground#alone(cmd:proc{$ P}
				{P.widget set(foreground:{String.toAtom P.1})}
			     end)
	title#alone(cmd:proc{$ P}
			   {P.toplevel set(title:P.1)}
			end)
	image#alone(cmd:proc{$ P}
			   try
			      {P.widget newImage('end' image:{New Tk.image tkInit(type:photo
										  url:P.1)})}
			   catch X then {Show X} end
			end)
	link#on
	'/link'#off(on:link
		    cmd:proc{$ P}
			   Tag=P.tag
			in
			   {Tag bind(event:"<Enter>"
				     action:proc{$} {P.widget set(cursor:hand2)} end)}
			   {Tag bind(event:"<Leave>"
				     action:proc{$} {P.widget set(cursor:left_ptr)} end)}
			   {Tag set(foreground:blue
				    underline:true)}
			end)
       ]
       proc{$ L}
	  K#V=L
       in
	  {H setFormat(K V)}
       end}
   end
   
   class HelpClass

      feat PanelDict
      
      from Hyperlink

      meth init
	 Hyperlink,init
	 self.PanelDict={NewDictionary}
	 {DefaultBind self}
	 {self setFormat('/link'
			 off(on:link
			     cmd:proc{$ P}
				    Tag=P.tag
				 in
				    {ForAll ["<1>" "<2>" "<3>"]
				     proc{$ B}
					{Tag bind(event:B
						  action:proc{$}
							    {{Dictionary.condGet self.PanelDict
							      P.id proc{$ _} skip end}
							     {Record.adjoinAt P button B}}
							 end)}
				     end}
				    {Tag bind(event:"<Enter>"
					      action:proc{$} {P.widget set(cursor:hand2)} end)}
				    {Tag bind(event:"<Leave>"
					      action:proc{$} {P.widget set(cursor:left_ptr)} end)}
				    {Tag set(foreground:blue
					     underline:true)}
				 end))}
	 {self setFormat(oz
			 alone(cmd:proc{$ P}
				      {{Compiler.evalExpression P.1 env _} P}
				   end))}
	 {self setFormat(toz on)}
	 {self setFormat('/toz' 
			 off(on:toz
			     cmd:proc{$ P}
				    {{Compiler.evalExpression P.1 env _} P}
				 end))}
%	 {self setFormat(urllink
%			 on)}
%	 {self setFormat('/urllink'
%			 off(on:urllink
%			     cmd:proc{$ P}
%				    {P.tag bind(event:"<1>"
%						action:proc{$}
%							  {BrowserControl.displayUrl P.1}
%						       end)}
%				    {P.tag bind(event:"<Enter>"
%						action:proc{$} {P.widget set(cursor:hand2)} end)}
%				    {P.tag bind(event:"<Leave>"
%						action:proc{$} {P.widget set(cursor:left_ptr)} end)}
%				    {P.tag set(foreground:blue
%					       underline:true)}
%				 end))}
      end

      meth openHelpWindow(Init)
	 Panel Place
	 ID={NewName}
	 Help={NewCell nil}
	 Mode={NewCell dual}
	 Prev={NewCell nil}
	 Next={NewCell nil}
	 ModeBtn
	 BackBtn
	 FwdBtn
	 fun{GetTitle L}
	    Title
	 in
	    {ForAll {self get(L $)}
	     proc{$ E}
		case E of title(X) then if {IsFree Title} then Title=X end else skip end
	     end}
	    if {IsFree Title} then L else Title end
	 end
	 fun{GetRef L}
	    if L==nil then nil else
	       Item={List.nth L 1}
	    in
	       {GetTitle
		if {IsAtom Item} then
		   Item
		else
		   Item.helppage
		end}
	    end
	 end
	 proc{SetBackFwdBtn}
	    {BackBtn set(state:if {Access Prev}==nil then disabled else normal end
			 tooltips:{GetRef {Access Prev}}
			)}
	    {FwdBtn set(state:if {Access Next}==nil then disabled else normal end
			tooltips:{GetRef {Access Next}}
		       )}
	 end
	 proc{AddHistory}
	    Ref=if {Access SelNode}\=nil then {Access SelNode} else {Access Current} end
	 in
	    {Assign Prev Ref|{Access Prev}} %% adds the reference in front for back button
	    {Assign Next nil} %% deletes entry for fwd button
	    {SetBackFwdBtn}
	 end
	 proc{PopHistory}
	    H={Access Prev}
	 in
	    if H==nil then skip
	    else
	       This=if {Access SelNode}\=nil then {Access SelNode} else {Access Current} end
	       Item={List.nth H 1}
	    in
	       {Assign Prev {List.drop H 1}}
	       {Assign Next This|{Access Next}}
	       if {Atom.is Item} then
		  {SetHelp Item}
	       else
		  {Item selectThisNode}
	       end
	    end
	    {SetBackFwdBtn}
	 end
	 proc{PushHistory}
	    H={Access Next}
	 in
	    if H==nil then skip
	    else
	       This=if {Access SelNode}\=nil then {Access SelNode} else {Access Current} end
	       Item={List.nth H 1}
	    in
	       {Assign Next {List.drop H 1}}
	       {Assign Prev This|{Access Prev}}
	       if {Atom.is Item} then
		  {SetHelp Item}
	       else
		  {Item selectThisNode}
	       end
	    end
	    {SetBackFwdBtn}
	 end
	 Win={QTk.build td(title:"Help window"
			   lr(glue:nwe
			      button(text:"Back"
				     action:PopHistory
				     handle:BackBtn
				     state:disabled
				     glue:w)
			      button(text:"Fwd"
				     action:PushHistory
				     handle:FwdBtn
				     state:disabled
				     glue:w)
			      button(text:"Single"
				     handle:ModeBtn
				     action:proc{$}
					       case {Access Mode}
					       of single then
						  {SetDisplay dual}
					       [] dual then
						  {SetDisplay single}
					       end
					       
					    end
				     glue:w))
			   lrline(glue:nwe)
			   placeholder(glue:nswe
				       handle:Place))}
	 Current={NewCell Init}
	 CanvasContents
	 Dual
	 DualHelp
	 Single
	 RootNode
	 SelNode={NewCell nil}
	 ThID={NewCell nil}
	 fun{BuildPanel}
	    SEntry SListBox
	    LB={NewCell nil}
	    fun{GetLink L}
	       {List.map
		{List.filter {self get(L $)}
		 fun{$ E}
		    {Record.is E} andthen {Label E}=='/link'
		    andthen {List.take E.1 5}\="http:"
		    andthen {List.take E.1 5}\="file:"
		 end}
		fun{$ E} {String.toAtom E.1} end}
	    end
	    fun{Search What}
	       Rx={Regex.make What}
	    in
	       {List.filter
		{self keys($)}
		fun{$ K}
		   {Regex.search Rx {self getText(K $)}}\=false
		end}
	    end
	    fun{SelectNode Node What}
	       if Node.helppage==What then
		  {Node selectThisNode}
		  true
	       elseif {IsDet Node.childrennodes} then
		  nil=={List.dropWhile Node.childrennodes
			fun{$ N}
			   {SelectNode N What}==false
			end}
	       else
		  false
	       end
	    end
	    proc{Display}
	       N={SListBox get(firstselection:$)}
	       L
	    in
	       try L={List.nth {Access LB} N} catch _ then skip end
	       if {IsDet L} then
		  {AddHistory}
		  {SetHelp L}
	       end
	    end
	 in
	    thread
	       {SEntry bind(event:"<Return>"
			    action:proc{$}
				      L={Search {SEntry get($)}}
				   in
				      {Assign LB L}
				      {SListBox set({List.map L
						     fun{$ R} {GetTitle R} end}
						   )}
				   end)}
	       {SListBox bind(event:"<1>"
			      action:Display)}
	       {SListBox bind(event:"<Return>"
			      action:Display)}
	    end
	    thread
	       class Node
		  from TreeNode
		  feat helppage childrennodes
		  meth init(...)=M
		     self.helppage=M.helppage
		     TreeNode,{Record.adjoinAt
			       {Record.subtract M helppage}
			       label {GetTitle self.helppage}}
		     {self bind(event:"<1>"
				action:proc{$}
					  {AddHistory}
					  {self selectThisNode}
				       end)}
		     if {GetLink self.helppage}==nil then {self expand} end
		  end
		  meth expand(...)=M
		     if {IsFree self.childrennodes} then
			self.childrennodes={List.map {GetLink self.helppage}
					    fun{$ Child}
					       N={New Node init(parent:self
								helppage:Child)}
					    in
					       {self addLeaf(node:N)}
					       N
					    end}
		     end
		     TreeNode,M
		  end
		  meth selectThisNode
		     if {Access SelNode}\=nil then
			{{Access SelNode} select(state:false)}
		     end
		     {self select(state:true)}
		     {self expand}
		     {SetHelp self.helppage}
		     {Assign SelNode self}
		  end
		  meth selectChildPage(Child)
		     if {IsDet self.childrennodes} then
			proc{Loop L}
			   case L
			   of X|Xs then
			      if X.helppage==Child then
				 {X selectThisNode}
			      else
				 {Loop Xs}
			      end
			   else
			      {SetHelp Child}
			   end
			end
		     in
			{Loop self.childrennodes}
		     end
		  end		      
	       end
	    in
	       RootNode={New Node init(canvas:CanvasContents
				       font:{QTk.newFont font(family:'Helvetica' size:10)}
				       height:18
				       helppage:home
				       label:{GetTitle home})}
	       {RootNode draw(x:2 y:2 height:_)}
	       {RootNode expand}
	       {SelectNode RootNode {Access Current} _}
	    end
	    panel(handle:Panel
		  td(glue:nswe
		     title:"Contents"
		     canvas(glue:nswe
			    handle:CanvasContents
			    background:white
			    tdscrollbar:true
			    lrscrollbar:true))
		  td(glue:nswe
		     title:"Search"
		     label(text:"Search keywords :" glue:nw)
		     entry(handle:SEntry glue:nwe background:white)
		     lrline(glue:nwe)
		     label(text:"Select page to display" glue:nw)
		     listbox(glue:nswe
			     background:white
			     tdscrollbar:true
			     lrscrollbar:true
			     handle:SListBox)))
	 end
	 proc{SetHelp Page}
	    if {Access Help}\=nil then
	       try
		  {Thread.terminate {Access ThID}}
	       catch _ then skip end
	       O={{Access Help} get($)}
	       TID
	    in
	       {{Access Help} set(empty)}
	       if O\=empty then
		  {O close}
	       end
	       {{Access Help} set({self getQTk(Page id:ID thid:TID $)})}
	       {Assign ThID TID}
	    end
	    if {Access SelNode}\=nil then {{Access SelNode} select(state:false)} end
	    {Assign SelNode nil}
	    {Assign Current Page}
	 end
	 proc{SetDisplay M}
	    if {Access Help}\=nil then
	       try
		  {Thread.terminate {Access ThID}}
	       catch _ then skip end
	       O={{Access Help} get($)}
	    in
	       {{Access Help} set(empty)}
	       {O close}
	    end
	    case M
	    of dual then
	       TID
	    in
	       {Place set(if {IsFree Dual} then
			     lrrubberframe(glue:nswe
					   {BuildPanel}
					   placeholder(glue:nswe
						       handle:DualHelp)
					   handle:Dual)
			  else
			     Dual
			  end	   
			 )}
	       {Assign Help DualHelp}
	       {DualHelp set({self getQTk({Access Current} id:ID thid:TID $)})}
	       {Assign ThID TID}
	       thread
		  {Delay 1000}
		  {Dual chgSize(Panel 150)}
	       end
	       {ModeBtn set(text:"Single")}
	    [] single then
	       TID
	    in
	       {Place set(if {IsFree Single} then
			     placeholder(glue:nswe
					 handle:Single)
			  else
			     Single
			  end
			 )}
	       {Assign Help Single}
	       {Single set({self getQTk({Access Current} id:ID thid:TID $)})}
	       {Assign ThID TID}
	       {ModeBtn set(text:"Dual")}
	    end
	    {Assign Mode M}
	 end
	 proc{Action P}
	    if {List.take P.1 5}=="http:" orelse
	       {List.take P.1 5}=="file:" then
	        {BrowserControl.displayUrl P.1}
	    else
	       case {String.toAtom P.button}
	       of '<1>' then
		  Page={String.toAtom P.1}
	       in
		  {AddHistory}
		  if {Access SelNode}\=nil then
		     {{Access SelNode} selectChildPage(Page)}
		  else
		     {SetHelp Page}
		  end
	       [] '<2>' then
		  thread
		     {self openHelpWindow({String.toAtom P.1})}
		  end
	       [] '<3>' then
		  skip
	       end
	    end
	 end
      in
	 {Dictionary.put self.PanelDict ID Action} %% purpose : allow several instances concurrently
	 {SetDisplay dual}
	 {Win show}
	 {Win set(geometry:geometry(width:400 height:300))}
	 {Win wait}
      end
      
   end

   
end