REBOL [
  Title: "Textual User Interface" 
  Date: 10-Jul-2000 
  Version: 0.0.1 
  File: %tui.r 
  Author: "Ingo Hohmann" 
  Email: ingo@2b1.de 
  Site:   http://www.2b1.de/Rebol/
  Rights: "(c) 7/2000 Ingo Hohmann" 
  Usage: [] 
  Purpose: {
  Create User interfaces using the text-screen
  }
  Comment: []
  History: [
    [10-Jul-2000 "Ingo Hohmann" "initial Version"]
  ] 
  Language: none 
  Category: ['text 'tools]  
  Known-bugs: [] 
  Status: 'initial
]

prompt: func [ {prompts for an editable string
  which is inserted into console/history (iho)}
  prompts [string!] "prompt string"
  defaults [string!] "default value"
][
  insert system/console/history defaults
  system/console/history: next system/console/history
  ask prompts
]


cursor: func [ "Positions the cursor (iho)"
  /direct "for cursor commands, that are not named"
  cmd [string!] "Command string"
  /home "positions the cursor at 1,1"
  /kill "kills to end of line"
  /clear "clears the screen"
  /up "sets cursor cnt1 lines up"
  cnt1 [integer!]
  /down "sets cursor cnt2 lines down"
  cnt2 [integer!]
  /right "sets cursor cnt3 rows right"
  cnt3 [integer!]
  /left "sets cursor cnt4 rows left"
  cnt4 [integer!]
  /pos "sets cursor to position row, col"
  posi [pair!]
  /del "deletes cnt5 chars"
  cnt5 [integer!]
  /space "inserts cnt6 spaces"
  cnt6 [integer!]
  /get-pos "returns block with cursor position"
  /get-screen "returns block with screen dimensions"
  /local pre ret
] [
  pre: copy "^(1B)[" ; to pacify emacs paren mode
  any [
    all [direct ret: join pre cmd]
    all [home   ret: join pre "H" ]
    all [kill   ret: join pre "K" ]
    all [clear  ret: join pre "J" ]
    all [up     ret: join pre [cnt1 "A" ]]
    all [down   ret: join pre [cnt2 "B" ]]
    all [right  ret: join pre [cnt3 "C" ]]
    all [left   ret: join pre [cnt4 "D" ]]
    all [pos    ret: join pre rejoin [posi/x ";" posi/y "H" ]]
    all [del    ret: join pre [cnt5 "P" ]]
    all [space  ret: join pre [cnt6 "@" ]]
  ]
  if any [
    all [get-pos    pre: join pre "6n" ]
    all [get-screen pre: join pre "7n" ]
  ] [
    cons: open/binary/no-wait [scheme: 'console]
    prin pre ret: next next to-string copy cons
    close cons
    ret: parse/all ret ";R"
    forall ret [change ret to-integer first ret]
    ret: to-pair head ret
  ]
  ret
]

doc {
  Usage:
  print cursor2 [ home "My header" pos 13x13 "this starts at 13x13" up 3 "Hey" ]
}
cursor2: func [ 
  {Cursor positioning dialect (iho)}
  [catch]
  commands [block!] 
  /local screen-size string arg cnt cmd c err
][
  ; get the size of the screen
  screen-size: console/get-screen
  ; some setup
  string: copy ""
  cmd: func [s][join "^(1B)[" s]
  ; compose, so that () get reduced
  if error? set/any 'err try [ commands: compose bind commands 'screen-size ] [
    throw err
  ]
  ; parse the dialect
  arg: parse commands [
    any [
      'direct set arg string! (append string arg) |
      'home                   (append string cmd "H") |
      'kill                   (append string cmd "K") |
      'clear                  (append string cmd "J") |
      'up    set arg integer! (append string cmd [arg "A"]) |
      'down  set arg integer! (append string cmd [arg "B"]) |
      'right set arg integer! (append string cmd [arg "C"]) |
      'left  set arg integer! (append string cmd [arg "D"]) |
      'pos   set arg pair!    (append string cmd [arg/x ";" arg/y "H" ]) |
      'del   set arg integer! (append string cmd [arg "P"]) |
      'space set arg integer! (append string cmd [arg "@"]) |
      'move  set arg pair!    (append string cmd [arg/x ";" arg/y "H" ]) |
      set cnt integer! set arg string! (append string head insert/dup copy "" arg cnt) |
      set arg string!         (append string arg) 
    ] end 
  ]
  if not arg [throw make error! "Unable to parse block"]
  ;return string to be printed
  string
]


console: make object! [
  title: "Key Definitions for the console (iho)"
  
  ; these work under my X11
  ; but maybe they have to be changed for you.
  ; There are some key, which would have several names, e.g.
  ; c-i = tab, c-h = back, ...
  ; a-* = 1B*
   
  name-key: compose [
    up    (rejoin [ #{1B} "[A" ])
    down  (rejoin [ #{1B} "[B" ])
    right (rejoin [ #{1B} "[C" ])
    left  (rejoin [ #{1B} "[D" ])
    esc   #{1B1B}
    pg-up (rejoin [ #{1B} "[5~" ])
    pg-dn (rejoin [ #{1B} "[6~" ])
    einfg (rejoin [ #{1B} "[2~" ])
    entf  (to-binary "^~")
    back  (to-binary "^H")
    home  (rejoin [ #{1B} "[1~" ])
    end   (rejoin [ #{1B1B} "[8~" ]) ; rejoin [#{1B} "[4~"] ; doesn't work
    c-a (to-binary #"^A")
    c-b (to-binary #"^B")
    c-c (to-binary #"^C")
    c-d (to-binary #"^D")
    c-e (to-binary #"^E")
    c-f (to-binary #"^F")
    c-g (to-binary #"^G")
    c-h (to-binary #"^H")
    tab (to-binary #"^-")
    lf  (to-binary #"^/")
    c-k (to-binary #"^K")
    c-l (to-binary #"^L")
    ret (to-binary #"^M")
    c-n (to-binary #"^N")
    c-o (to-binary #"^O")
    c-p (to-binary #"^P")
    c-q (to-binary #"^Q")
    c-r (to-binary #"^R")
    c-s (to-binary #"^S")
    c-t (to-binary #"^T")
    c-u (to-binary #"^U")
    c-v (to-binary #"^V")
    c-w (to-binary #"^W")
    c-x (to-binary #"^X")
    c-y (to-binary #"^Y")
    c-z (to-binary #"^Z")
    f1 #{1B4F50}
    f2 #{1B4F51}
    f3 #{1B4F52}
    f4 #{1B4F53}
    f5 #{1B5B31357E}
    f6 #{1B5B31377E}
    f7 #{1B5B31387E}
    f8 #{1B5B31397E}
    f9 #{1B5B32307E}
    f10 #{1B5B32317E}
    f11 #{1B5B32327E}
    f12 #{1B5B32337E}
    c-f1 #{1B5B31315E}
    c-f2 #{1B5B31325E}
    c-f3 #{1B5B31335E}
    c-f4 #{1B5B31345E}
    c-f5 #{1B5B31355E}
    c-f6 #{1B5B31375E}
    c-f7 #{1B5B31385E}
    c-f8 #{1B5B31395E}
    c-f9 #{1B5B32305E}
    c-f10 #{1B5B32315E}
    c-f11 #{1B5B32335E}
    c-f12 #{1B5B32345E} 
    gr-div #{1B4F6F}
    gr-mul #{1B4F6A}
    gr-sub #{1B4F6D}
    gr-plus #{1B4F6B}
    gr-enter #{1B4F4D}
    gr-entf #{1B4F6E}
    gr-0 #{1B4F70}
    gr-1 #{1B4F71}
    gr-2 #{1B4F72} ; I got #{1B4F77} ???
    gr-3 #{1B4F73}
    gr-4 #{1B4F74}
    gr-5 #{1B4F75}
    gr-6 #{1B4F76}
    gr-7 #{1B4F77}
    gr-8 #{1B4F78}
    gr-9 #{1B4F79}
  ]
  key-name: reverse-key-val name-key
  
  ; helper, forget about it ....
  test-helper: func [ "to test keyboard codes, press q to exit (iho)"] [
    key-list: copy []
    i: 1
    until [
      c: wait
      if binary? c [ append key-list compose [ (to-set-word rejoin["c-f" i]) (c) ]]
      ++ i
      print c
      c = #"q"
    ]
    key-list
  ]
  
  get-key: func [
    "returns key-code for name (iho)"
    'name [string! word! char!]
    /local key
  ] [
    either key: select name-key name [
      print "found name"
      return key
    ][
      either 1 <> length? parts: parse/all to-string name "-" [
        print "trying to compute"
        if "c" = pick parts 1 [
          return rejoin [ #"^^" pick parts 2 ]
        ]
      ] [
        print "not found"
        return name
      ]
    ]
  ]
  
  get-name: lfunc [
    "returns name to key-code"
    'code [string! binary! char!]
  ] [
    either ret: select key-name code [ret][code]
  ]
  
  get-screen: func [
    "Get screen size"
    /local cons ret
  ] [
    cons: open/binary/no-wait [scheme: 'console]
    prin "^(1B)[7n"
    ret: next next to-string copy cons
    close cons
    ret: parse/all ret ";R"
    forall ret [change ret to-integer first ret]
    ret: to-pair head ret
  ]

  wait: func ["Reads from console (iho)" /test /local alt con inp] [
    con: open/binary/no-wait [scheme: 'console]
    system/console/break: off
    inp: system/words/wait either test [[con 0]][con]
    system/console/break: on
    either port? inp [
      inp: copy/part con 1
      probe inp
      while ["^(1B)" = inp] [
        inp: copy/part con 1
      ]			
      close con
      ; if 27 = first inp [ inp: next inp alt: true ]
      either found? ret: select key-name inp [
        return ret
      ][
        if error? try [
          return to-char to-integer inp
        ] [
          return inp
        ]
      ]
    ] [
      close con
    ]
  ]
]


;
; A menu system, needed for pager
;


menu-object: make object! [
   Title: "Creates a menu system (iho)"
   header: copy "^LHelp"
   menus: copy []


   init: func [ "Initialize menu (iho)" /data men [block!] /local key help action] [
      either data [
		 menus: copy men
      ] [
		 menus: copy []
      ]
   ] ; init


   FIXME: "add /at position  refinement"
   add: func [ 
	  "Adds a new menuline (iho)"
	  key [char! none!] help [string! none!] action
	  [block! none!]
   ] [
	  append menus key
	  append menus help
	  append/only menus action
   ] ; add


   show: func [ 
	  "Shows the menu (iho)" 
   ] [
      print rejoin [ header ]
      foreach [key help action] menus [
         prin either not 'none = key [
            [rejoin ["("key") "]]
            [rejoin [ align/center form key 5 " " ]]
		 ] [
			"      "
		 ]
         print either string? help
		 [help]
		 [""]
      ]
      print " "
   ] ; show


   ask: func [
      "Waits for a keypress, and DOes menu action (iho)"
      /local c key help action ret
   ][
      c: console/wait
      foreach [key help action] menus [
		 if key == c [
			either error? set/any 'ret try [ do action true ] [
			   print rejoin ["Error in menu function: " action]
			   if confirm "... would you like to inspect (y/N)? " [
				  print mold disarm ret
				  ask "Press <Return>"
			   ]
			   return none
			] [
			   return ret
			]
		 ]
      ]
   ]

   loop: func [ {After keypress, starts waiting for the next key,
           you'd better have a halt in one of your menu actions (iho)}
      /show "always show the menu, before waiting for keypress"
      /do "always do action before waiting"
      todo [block!] "action to do"] [
      while [ true ] [
         if show [ self/show ]
         if do   [
            if error? try todo [
               print "Error while doing menu action!"
            ]
         ]
         ask
      ]
   ] ; loop
   ;   ] ; use
] ; make menu

;
; A text pager
;

; extracted from messenger.r by Bohdan Lechnowsky <bo@rebol.com>
; and Andrew M Grossmann <Andrew.M.Grossmann@ >
; changed by iho
; FIXME: wrap lines, and count them, too

pager: make object! [
   Title: "A String pager"
   author: "Ingo Hohmann"
   header: [ "^LPager" ]
   footer: [ perc "% command: " ]
   curr-line: 1
   view-lines: (first cursor/get-screen) - 3
   FIXME: "view-columns: 80"
   content: copy ""
   keep-going: true

   init-header: func [{Initializes the header (iho)} new-hdr] [
      header: copy new-hdr
   ]

   init-footer: func [{Initializes the footer (iho)} new-foot] [
      footer: copy new-foot
   ]

   validate: func [{Validate I'm still within the text (iho)}] [
      if curr-line < 1 [curr-line: 1]
      if curr-line > ((length? content) - view-lines) [
         curr-line: (length? content) - view-lines
      ]
   ]

   menu: make menu-object [
      menus: [
         none "Paging" none
         #"b" "Back one page"
            [curr-line: curr-line - view-lines  validate]
         #"f" "Forward one page"
            [curr-line: curr-line + view-lines  validate]
         #" " "forward one page"
            [curr-line: curr-line + view-lines  validate]
         #"p" "Previous line"
            [curr-line: curr-line - 1           validate]
         #"n" "Next line"   [curr-line: curr-line + 1 validate]
         none "Window" none
         #"," "decrease view lines by 1" [view-lines: view-lines - 1]
         #"." "increase view lines by 1" [view-lines: view-lines + 1]
         #"<" "decrease view lines by 5" [view-lines: view-lines - 5]
         #">" "increase view lines by 5" [view-lines: view-lines + 5]
         none "Other" none
         #"q" "quit pager"  [keep-going: false]
         #"h" "Help"  [menu/show menu/ask]
      ]
   ]

   do: func [ {Do the actual paging (iho)} string {text to page thruogh} /local line]  [
      content: parse/all string "^/"
      curr-line: 1

      keep-going: true
      while [keep-going] [
         print rejoin header
         for line curr-line (curr-line + view-lines) 1 [
            if pick content line [print pick content line]
            a: line
         ]
         if ((perc: to-integer (100 * (a / length? content))) > 100) [
            perc: 100
         ]
         prin rejoin footer
         menu/ask
      ]
      print " "
      exit
   ]
] ; pager


tui: make object! [
   Title: {Textual User Interface}

   list: func [] [
   ]
]


pager2: make object! [
  Title: "A Screen Pager (Version 2)"
  author: "Ingo Hohmann"

  text-pos: 0x0
  block: copy []
  screen-size: 25x80
  
  new-text-pos: func [ move [pair!] ] [
    text-pos: max 0x0 (text-pos + move)
    text-pos/x: min text-pos/x ((length? block) - screen-size/x)
  ]
  
  menu: make menu-object [
    menus: [
      none "Paging" none
      #"b" "Back one page" [
        new-text-pos to-pair reduce [- screen-size/x 0] ]
      #"f" "Forward one page" [
        new-text-pos to-pair reduce [screen-size/x 0] ]
      #" " "forward one page" [
        new-text-pos to-pair reduce [screen-size/x 0] ]
      up "Previous line" [
        new-text-pos -1x0 ]
      down "Next line" [
        new-text-pos 1x0 ]
      left "shift left" [
        new-text-pos 0x-10 ]
      right "shift right" [
        new-text-pos 0x10 ]
      none "Other" none
      #"q" "quit pager" [prin cursor2 [clear] halt]
      #"h" "Help"  [menu/show menu/ask]
    ]
  ]
  
  set 'less func [
    {
    A screen pager in (object pager2) (iho)
    }
    text [string!] "text to display"
    /local line line-nr str err
  ] [
    screen-size: console/get-screen
    text: replace/all text "^-" "^^-"
    block: copy []
    
    print  "starting to parse"
    parse/all text [
      some [
        copy str to newline skip (append block either str [str][""])
      ] 
      copy str to end (append block either str [str][""]) 
    ]
    text-pos: 0x0
    text: none ; so it can be freed
    
    forever [
      line-nr: text-pos/x
      screen-line: 1
      loop screen-size/x [
        line-nr: line-nr + 1
        ; FIXME: lines are not cleared ...
        if line: pick block line-nr  [
          line: copy/part skip line text-pos/y (screen-size/y)
          ; ATTENTION: This works only for full-screen (kill)
          prin cursor2 compose [pos (to-pair reduce [screen-line 1]) (line) kill ]
        ]
        screen-line: screen-line + 1
      ]
      prin cursor2 [home]
      menu/ask
    ]
    exit
  ]
]

;less read home ashes.txt
;less read home .bashrc
;less read %/usr/local/bin/cheap-call

border: func [ 
   {
      Draws a border (iho)
   }
   pos [pair!] size [pair!]
   /header
   text [string!]
   /local space line eps string skip
] [
   line: head insert/dup next copy "++" "-" (size/y - 2)
   space: cursor2 [ "|" right (size/y - 2) "|" ]
   skip: 2
   string: cursor2 compose [ 
      pos (pos) (line) 
   ]
   if header [
      text: copy/part text size/y - 2
      eps: to-pair compose [ 1 (to-integer (size/y / 2 - ((length? text) / 2))) ]
      append string cursor2 compose [ 
	 pos (pos + 1x0) (space) 
	 pos (pos + 2x0) (line) 
	 pos (pos + eps) (text)
      ]
      pos/x: pos/x + 2
      skip: 4
   ]
   loop size/x - skip [
      pos/x: pos/x + 1
      append string cursor2 [ pos (pos) (space) ]
   ]
   append string cursor2 [ pos (pos) (line) ]
]

text-width: func [
  {breaks a text into lines of at most width characters (iho)}
  text [string!] width [integer!] 
  /local chars line spaces new-line line-startword-start word-end 
][
  text: replace/all copy text "^-" "    "

;  chars: complement charset ""
;  parse/all text [
;    any [
;      copy line width chars pos: (insert pos newline) skip |
;      thru newline
;    ]
;    end
;  ]

  spaces: charset " ^-"
  new-line: charset "^/"
  chars: complement union spaces new-line
  non-chars: complement chars
  width: width - 2
  word-start: word-end: txt
  parse/all text [
    line-start:
    any non-chars
    any [
      word-start:
      some chars
      word-end:
      (
        if width < ((index? word-end) - (index? line-start)) [
          print copy/part word-start 10
          change back word-start "^/" ;newline
          line-start: next word-start
        ]
      )
      any spaces
      [ newline line-start: | none ]
    ]
  ]
  text
]

[

txt: {   Das ist ein weiterer Test-text, diesmal direkt in der Datei,
damit ich nicht wieder       den ganzen Text
aus versehen loesche.

Mal sehen.
}

print [ "Ergebnis:" newline text-width txt 20 ]

]