REBOL [
   Title: "Definitions"
   Date:  1999-9-8
   Purpose: {Definitions for functions, I like to have
        always at hand}
   File: %Definitions.r
;;   Needs: 2.1.2
   Author: "Ingo Hohmann and others"
   email:  ingo@2b1.de
   site:   http://www.2b1.de/Rebol/
   Rights: "(c) Ingo Hohmann"
   Comments: {
      - Now some functions for 2.2 are present, e.g. 
        my cursor function, previously seen at the rebol list.
      - On rebol > 2.1.90 the prompt function copies the 
        default value into history, cursor up to edit it.
      - Some functions are from other persons.
      - this script only contains new functions, not present
        in rebol/core, there should be no problems with 
   protect-system}
   Usage: {place: do %Definitions.r in your %user.r}
   Category: 'Utility
   ToDo: [
        {make pager work with files longer than screen width}
        ]
]

;
; Functions by Ingo Hohmann
;

revdom: func [ 
    {reverts a domain name}
    domain [string!]
] [
    domain: copy domain
    either p: find/reverse find/reverse tail domain "." "." [
       dom: copy next p
       clear p
       while [ p: find/reverse p "." ] [
          append dom p
          clear p
       ]
       append dom join "." domain
    ] [ domain ]
]

to-bin-str: func [
    {converts binary to binary string}
    bin [binary!]
][
    system/options/binary-base: 2
    bin: copy next next next form bin
    bin: copy/part bin (length? bin) - 1
]

&: func [ {bitwise and}
    bin1 [string! binary!] bin2 [string! binary!] 
] [
   if binary? bin1 [
      bin1: to-bin-str bin1
   ]
   if binary? bin2 [
      bin2: to-bin-str bin2
   ]
   for i 1 length? bin1 1 [
      change at bin1 i (all [pick bin1 i = #"1" pick bin2 i = #"1"]) 
   ]
   bin1
] 

convert: func [ "Converts a text-file to platform-format"
   'file [file! word!]
][
   write to-file file detab/size read to-file file 3
]

;
euro-calc: func [
   "Currency Calculator"
   val [money!] to-curr [string! word! unset!]
   /local nval to-eu to-loc
][
   to-curr: either value? 'to-curr [uppercase form to-curr]["EUR"]
   to-eu:  ["EUR" 1 "DEM" 1.95593 "DM" 1.95593 "" 1.95593 ]
   val: val / select to-eu  first val
   val: val * select to-eu to-curr
   poke val 1 to-curr
]
;euro-calc dem$20 "eur"
;a: dem$20
;euro-calc a "eur"
;a

require: func [ "Tests, if test is true" [catch]
   test [block!]
] [
   if not do test [
      throw make error! rejoin ["require failed on: " test ]
   ]
]

ensure: func [ "Tests, if test is true" [catch]
   test [block!]
] [
   if not do test [
      throw make error! rejoin ["require failed on: " test ]
   ]
]


dbc-func: func [
   "Defines a user function with given spec and body." [catch]
   spec [block!] {Help string (opt) followed by arg words (and opt type and string)}
   body [block!] "The body block of the function"
][
   if 'require = first body [
      either string? first spec [
         append first spec rejoin ["^/Require:^/    " form second body]
      ] [
         insert spec rejoin ["^/Require:^/    " form second body]
      ]
   ]
   if 'ensure = pick body 3 [
      append first spec rejoin ["^/Ensure:^/    " form pick body 4 " " form pick body 5]
   ]
   throw-on-error [make function! spec body]
]


comment [
   a: make object! [
      b: make object! [
         c: func [{This is a/b/c 
with a longer help string for testing} /d][
            either d [print "c/d is started"]
               [print "c   is started"]]
         e: func ["This is a/e"][print "huhu"]
         f: 3
         g: make object! [
            h: "kjhkjh"
            i: 10.3
         ]
         h: func [] [print "hey"]
         i: func [x] [print "yup"]
         j: func [a "heyhey" b [string!] c [integer!] "yea"][print "do nothing"]
         k: 2000-12-13
         l: 255.1.1
         m: 1.238746283756897645872364578364578236485763827456
         n: 23894029579038475982375928375293475902873462
         o: 96096969
      ]
   ]
   >> a: to-word "a"
   == a
   >> type? get in :x 'b
   == object!

]; comment



ohelp: func [
   {help on functions in objects, e.g. 'a/b phelp a/b}
   'obj [object!]"the path to get help for"
   /local wrd help
] [
   foreach wrd next first obj [
      either function? get in obj wrd [
         print [wrd ":  func" either string? help: first third get in obj wrd [mold help][""]]
      ] [
         print [wrd ": " type? get in obj wrd]
      ]
   ]
]


ehelp: func [
   {help on functions in objects, e.g. 'a/b phelp a/b}
   'path [path!] "the path to get help for"
   /local parts obj i j
] [
   i: 2
   parts: parse mold :path "/"
   if error? try [obj: get to-word first parts] [
      print ["Path:" :path "not found"]
      exit
   ]
   while [all [object? :obj i <= length? parts] ] [
      either not error? try [obj: get in obj to-word pick parts i] [
         ++ i
      ] [
         break
      ]
   ]
   pth: first parts
   for j 2 i - 1 1 [
      append pth rejoin ["/" pick parts j ]
   ]
   prin rejoin [{Valid subpath "} pth]
   either function? :obj [
      print {" is function:^/}
      help obj
   ][
      either object? :obj [
         print {" is object:^/}
         ohelp obj
      ] [
         print ["Path:" :path "not found"]
      ]
   ]
]

reverse-key-val: func [
   "exchanges key/value pairs in a block, for reverse look-up"
   look-up [block!]
   /local reverse
] [
   reverse: make block! length? look-up
   for i 1 length? look-up 2 [
      append reverse compose [ (pick look-up (i + 1)) (pick look-up i)]
   ]
   reverse
]

console: make object! [
   "Key Definitions for the console"

   ; these work under my X11
   ; c-a = 1 ...
   ; 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 [ #{1B} "[8~" ])
      ret   (to-binary "^M")
      tab   (to-binary "^-")
      c-k    (to-binary "^k")
      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}
      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} ]
   key-name: reverse-key-val name-key

   wait: func ["Reads from console" /local alt con inp] [
      con: open/binary [scheme: 'console]
      system/console/break: off
      system/words/wait con
      system/console/break: on
      inp: copy con
      if error? try [
         for i 2 length? inp 1 [
            prin [ to-char to-integer pick inp i]
         ]
      ]['ok]
      ;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
         ]
      ]
   ]

   test: func [] [
      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-codes for name"
      name [string!]
      /local pos
   ] [
      probe get-name
      either found? pos: find key-name name [
         return first back pos
      ][
         parts: parse name "-"
         if "c" = pick parts 1 [
            return to-char rejoin [ "^^" pick parts 2 ]
         ]
      ]
   ]
]

unprotect-system: func [
   {UN-Protect all system functions and 
      the system object from redefinition.}
   /locals vals words word
][
   vals: second system/words
   words: make block! 1
   foreach word first system/words [
      if any-function? first vals [append words word]
      vals: next vals
   ]
   foreach word bind words 'read [unprotect word]
   unprotect 'system
]

cursor: func [ "Positions the cursor"
   /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"
   row [integer!] col [integer!]
   /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 [row ";" col "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 [scheme: 'console]
      print pre ret: next next to-string copy cons
      close cons
      ret: parse/all ret ";R"
      change at ret 1 to-integer first ret
      change at ret 2 to-integer second ret
   ]
   ret
]

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

catch-error: func [
   "Catches Errors inside block, and forgets about them"
   blk [block!]
][
   if error? try [ do blk ] []
]

date: func ["Shows date in DIN format" /local d] [
   d: to-idate now
   parse d [copy d to " +" to end]
   d: rejoin [ "" now/year "-" now/month "-" now/day ]
   d
]

time: func ["Shows the current time"] [now/time]

;
; A menu system, needed for pager
;

menu-object: make object! [

   header: copy "^LHelp"
   menus: copy []

   init: func [ "Initialize menu" /data men [block!]] [
      either data [menus: copy men]
         [menus: copy []]
   ] ; init

   FIXME: "add /at position  refinement"
   add: func [ "Adds a new menuline"
      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" ] [
      print rejoin [ header ]
      foreach [key help action] menus [
         prin either char? key
            [rejoin ["("key") "]]
            ["    "]
         print either string? help
            [help]
            [""]
      ]
      print " "
   ] ; show

   FIXME: {update to use new key codes}
   ask: func [ "Waits for a keypress, and DOes menu action"
      /local con c key help action
   ] [
      catch-error [
         con: open/binary [scheme: 'console]
         wait con
         c: to-char to-integer copy con
         foreach [key help action] menus [
            if key == c [
               if error? err: try [ do action true ] [
                  print rejoin ["Error in menu function: " action]
                  if confirm "... would you like to see it (y/N)? " [
                     print mold disarm err
                     ask "Press <Return>"
                  ]
                  return 'error
               ] [
                  'none
               ]
            ]
         ]
         return 'not_found
      ]
   ] ; ask

   loop: func [ {After keypress, starts waiting for the next key,
           you'd better have a halt in one of your menu actions}
      /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! [
   header: [ "^LPager" ]
   footer: [ perc "% command: " ]
   curr-line: 1
   view-lines: either REBOL/version > 2.1.89
      [(first cursor/get-screen) - 3][25]
   FIXME: "view-columns: 80"
   content: copy ""
   keep-going: true

   init-header: func [new-hdr] [
      header: copy new-hdr
   ]

   init-footer: func [new-foot] [
      footer: copy new-foot
   ]

   validate: func [] [
      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 [string /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 found? 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
   ]

]


;
; save words to a block, that can be restored with load later
;

save-words: func[ {Save words and their values to a block, that can be 
                  DOne to restore, doesn't work for native}
   words [block!] "Block of words to save"
   /local bloc] [
   bloc: copy []
   foreach w words [
      append bloc load script w
   ]
   load bloc
]

;
; a message function, thats quiet if rebol is started with -q
;

message: func ["Prints value, if not quiet" value] [
   if not system/options/quiet [
      print value
   ]
]

;
; functions for objects
;

;
; Create a block from an object
;

object-to-block: func [
   "make a formatted block out of an object"
   obj [object!]
   /local str name val] [
   str: copy "[^/"
   foreach name next first obj [
      val: mold obj/:name
      append str rejoin [name ": " val "^/"]
   ]
   ;print str
   append str copy "]^/"
   load str
]


newscript: func ["Creates a file containing a script header"
   /local newfile head heado val][
   newfile: to-file ask "Filename: "
   newtitle: ask        "Title:    "
   newhistory: compose/deep [
         [ (now/date) (system/user/name) {initial Version} ]
   ]
   heado: make system/standard/script [
      Author: system/user/name
      Email:  system/user/email
      Home:   system/user/home
      Date:   now/date
      File:   newfile
      Title:  newtitle
      Version: 0.0.1
      History: newhistory
      Category: []
      Known-bugs: []
      Rights: rejoin [{(c) } now/month "/" now/year { } Author]
      Status: to-lit-word 'initial
      Comment: []
      Usage: []
   ]

   head: object-to-block heado

   save/header rejoin [
      first yamm/search-paths newfile] rejoin [" "] head
] ; newscript

;
; Functions by others
;

;
; text alignment
; needed for history
; by Bohdan Lechnowsky <bo@rebol.com> (?)
;

align: function [
   {Forms data into a specified number of columns 
   with optional alignment}
   data length /left /right /center] [len] [
   if right [
      return head copy/part
      tail insert/dup head form data " " length
         (length * -1)
   ]
   if center [
      data: head insert/dup head form data " " len: (length / 2)
      data: head insert/dup tail data " " len
      return copy/part at data ((length? data) / 2 - len + 1) length
   ]
   return copy/part head insert/dup tail form data " " length length
]

;
; history
;

; history finder 2
; by eric <KGD03011@nifty.ne.jp>
; iho
; There's now a much improved version on www.rebol.org
h: func [
   {bring matching commands to front of history list (. and * wild)}
   'matcher [word! any-string! number!]
   {if number, gets the the specified entry to edit it, 
         should only be used EXACTLY after a listing}
   /wc {use alternate wild cards (? and +)}
   /n {don't print history list}
   /r {remove from history list}
   /local mlist nlist pos funct
][
   either number? matcher [
      pos: matcher + (length? system/console/history) - len
      funct: prompt "h> " copy pick system/console/history pos
      do funct
      exit
   ] [
      len: (length? system/console/history) - 2
   ]
   pos: 1
   mlist: copy []
   nlist: copy []
   either wc [wc: "?+"][wc: ".*"]
   matcher: to-string matcher
   foreach i system/console/history [
      either find/match/with i matcher wc [
         if not r [ append mlist i ]
         if not n [ print rejoin [align/right pos 3 ": " i] ]
         pos: pos + 1
      ] [
         if all [not find/match i "h " i <> "h"][append nlist i]
      ]
   ]
   insert nlist mlist
   system/console/history: copy nlist
   exit
]


;
; History save and load by Christoph Mammitzsch
; iho (delete lines with less then 4 characters)
;
save-history: func [
   "Saves system/console/history to file."
   file [ file! ] "the file to save to"
   /local history line subst
][
   history: copy/part system/console/history 500
   until [
      either 4 > (length? (first history))
         [remove history]
         [history: next history]
      tail? history
   ]
   history: head history
   forall history [
      line: mold first history
      if equal? first line #"{" [
         line: change line #"^""
            forall line [
                subst: select [
                    #"^""   "^^^""
                    #"^/"   "^^/"  
          ;There must be more. I'm sure I forgot something :)
                ] first line        
                if not none? subst [
                    remove line
                    line: back insert line subst
                ]
            ]
            change back line #"^""
         line: head line
      ]
      change/only history line
   ]
   history: head history
   write file history
   exit
]

load-history: func [
   "Restores system/console/history from file."
   file [ file! ] "the file to load from"
   /local history
][
   system/console/history: load file
   exit
]

;
; by eric
;

form-decimal: func [
   {format a number}
   number [number! any-block!] "number or block of numbers to format"
   decimal [integer!] {decimal places to leave}
   /local digit n whole fraction exponent neg
][
   either any-block? number [
      n: reduce copy number
      whole: make type! n length? n
      foreach x n [
         insert/only tail n form-decimal x decimal
      ]
   ][
      n: form number
      digits: charset [#"0" - #"9"]
      parse n [
            [ copy neg "-" | none (neg: copy "")]
            [ copy whole some digits | none (whole: copy "") ]
            [ "." copy fraction some digits | none (fraction: copy "")]
            [ "E" copy exponent [["+" | "-"] some digits ] | none (exponent: 0
            )]        ]
      exponent: decimal + to-integer exponent
      either exponent >= 0 [
         insert/dup tail fraction "0" 1 + exponent - length? fraction
         insert tail whole copy/part fraction exponent
         remove/part fraction exponent
      ][
         insert/dup whole "0"  1 - (length? whole) - exponent
         insert fraction copy skip tail whole exponent
         clear skip tail whole exponent
      ]
      if 0.5 <= to-decimal join "." fraction [
         whole: mold 1 + to-integer whole
      ]
      insert/dup whole "0" decimal - length? whole
      either decimal > 0 [
         insert skip tail whole (- decimal) "."
         if find/match whole "." [insert whole "0"]
      ][
         if whole <> "0" [insert/dup tail whole "0" (- decimal)]
      ]
      n: join neg whole
   ]
   n
]

;
; by Ladislav
;
floor: func [
   "Next bigger Integer"
   x [number!] /local y
] [
      (y: to-integer x) - to-integer x < y
]

ceiling: func [
   "Next lower Integer"
   x [number!] /local y
] [
      (y: to-integer x) + to-integer x > y
]

;
; Jerry
;
round: func [
   "Round to number of decimals"
   x [integer! decimal!] "Value to round"
   n [integer!] "Number of decimals"
][
   either x >= 0
      [
      x: (x * (10 ** n)) + 0.5
      x: x - (x // 1)
      x: x * (10 ** - n)
   ]
      [x: - round - x n]
]

;String functions:

; Bo
right: func [S [string!] N [integer!]] [copy/part tail S negate N]

; Andrew Martin
left: func [S [string!] N [integer!]] [copy/part S N]
mid: func [S [string!] I [integer!] N [integer!]] [copy/part at S I N]

;
; Bohdan Lechnowsky <bo@rebol.com>
;

multi-replace: func [series [series!] pairs [block!]][
   foreach [a b] pairs [
      replace/all series a b
   ]
]

shift: func [
   "Takes a base-2 binary string and shifts bits Bo@rebol.com"
   data [string!]
   places [integer!]
   /left
   /right
   /carry
   /local first-bits last-bits
][
   if any [places < 1 all [(places >= length? data) not carry]] [
      print {ERROR: Shift places exceeds length of binary data or is invalid}
      exit
   ]
   places: places // (length? data)
   either right [
      last-bits: copy/part tail data (places * -1)
      if not carry [last-bits: head insert/dup copy "" "0" places] remove/part tail data (places * -1)
      data: head insert head data last-bits
   ] [
      first-bits: copy/part data places
      if not carry [first-bits: head insert/dup copy "" "0" places] remove/part data places
      append data first-bits
   ]
   data
]


;
; authors unknown
;

unset!: do [type?]

set '++ func ['word] [set word (get word) + 1]
set '-- func ['word] [set word (get word) - 1]

words-of: func [{Returns block of object words next to self directive}
   object-name [object!]
   {Object of which word names should be returned}
][
   copy next first object-name
]

values-of: func [
   {Returns block of object word values next to self directive}
   object-name [object!] {Object words of which its values
        should be returned}
][
   copy next second object-name
]

;foreach word words-of system/network [print word]
;foreach value values-of system/network [print value]