home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v941.tgz / icon.v941src.tar / icon.v941src / ipl / progs / literat.icn < prev    next >
Text File  |  2002-03-26  |  31KB  |  1,084 lines
  1. ############################################################################
  2. #
  3. #    File:     literat.icn
  4. #
  5. #    Subject:  Program to manage literature information
  6. #
  7. #    Author:   Matthias Heesch
  8. #
  9. #    Date:     March 26, 2002
  10. #
  11. ############################################################################
  12. #
  13. #   This file is in the public domain.
  14. #
  15. ############################################################################
  16. #
  17. #    Database system to manage information concerning literature.
  18. #
  19. ############################################################################
  20. #
  21. #           Written by: Dr. Matthias Heesch
  22. #           Department of Protestant Theology (FB 02)
  23. #            Johannes Gutenberg University
  24. #         Saarstrasse 21 / D-W-6500 Mainz 1 / Germany
  25. #
  26. ############################################################################
  27. #
  28. #  Written and tested under: DR/MS-DOS, using ansi.sys
  29. #
  30. ############################################################################
  31. #
  32. #  See the comment lines concerning the single user defined
  33. #  functions if you want to use them separately. Note that all screen
  34. #  access assumes ansi.sys to be installed.
  35. #
  36. #  Since arguments to the seek() function may be long integers,
  37. #  long-integer support is required.
  38. #
  39. #  The program uses standard files literat.fil, literat2.fil and
  40. #  adress.fil to store its data on the disk. It has a predefined
  41. #  structure of the items and predefined field labels to make it easy
  42. #  to use and to cut down the source code length.for users having some
  43. #  knowledge of the Icon language it shouldn't be difficult to
  44. #  change the program. In this case the item length (now 846 byte)
  45. #  the option lists in menue() and the field label list have to be
  46. #  modified. The main changes then will concern user defined
  47. #  function edit_item() where the number of fields within an item
  48. #  is decided by *labels. In function in_itemm() the number of dummy
  49. #  field separators has to be equal to the amount of fields desired.
  50. #  (items := list(200,"##" if two fields are desired). Within the
  51. #  other functions only the amount of bytes for a whole item within
  52. #  reads() and seek() operation has to be changed accordingly. Note
  53. #  that "literat"'s editor in its present version isn't able to scroll.
  54. #                                
  55. #  See the description (comment lines) of user defined function
  56. #  line() for details of the editing facilities.         
  57. #
  58. #  The menue accepts input by <arrow up/dn> and the lower case short
  59. #  hand key of every option. The selected option has to be activated
  60. #  by <ret>.                            
  61. #
  62. #  iNPUT: function to update an existing file literat.dat. When moving
  63. #  the cursor out of the actual item, the last or following item will
  64. #  be displayed and is available for the editing process. Input treats
  65. #  literat.dat as a sequential file. Only the items to be added to the
  66. #  existing file are in the computer's memory. This fastens the option
  67. #  to switch between the (new) items. Otherwise it would have been
  68. #  necessary to load the whole literat.dat into the RAM or to load
  69. #  every new item from the disk. The first would consume too much
  70. #  memory with the result of potential loss of new items, the second
  71. #  would cost much time. In one session "literat" can accept no more
  72. #  than 200 new items.
  73. #
  74. #  tURN_OVER_ITEMS: literat.dat can be viewed and edited item by item
  75. #  moving the cursor out of the actual item causes the next/last item
  76. #  to be displayed. The edited items are written to file literat2.fil
  77. #
  78. #  aDRESS file: type words to be indicated. If they are found, the
  79. #  item numbers of their occurrence will be recorded in file adress.fil.
  80. #  Moving the cursor out of the editor causes the indicating    
  81. #  process to start. New items to adress.fil are simply added to the
  82. #  file. Therefore changes of existing material in adress.fil have to
  83. #  be made by creating a new adress.fil.             
  84. #
  85. #  qUERY: searches item using the information in adress.fil. You are
  86. #  prompted to type a word and if it's found in adress.fil the
  87. #  programm will use the item numbers to compute arguments to the
  88. #  seek()-function and then read the item. After viewing and if    
  89. #  desired editing the item it will be written to file literat2.fil.
  90. #
  91. #  dEL: prompts for an item number and removes the corresponding item.
  92. #  the file then is written to literat2.fil, literat.fil remains
  93. #  as it was.
  94. #
  95. #  AlPHA: alphabetical sorting, sorted file written to literat2.fil.
  96. #
  97. #  eND: return to the operating system.                
  98. #
  99. ############################################################################
  100. #
  101. #  Important message to the user: everybody who will find and remove
  102. #  a bug or add any improvement to the program is kindly encouraged
  103. #  to send a copy to the above address.                
  104. #
  105. ############################################################################
  106. #
  107. #  Note:  Clerical edits were made to this file by the Icon Project.
  108. #         It's possible they introduced errors.
  109. #
  110. ############################################################################
  111. #
  112. #  Requires:  large-integer arithmetic, ANSI terminal support
  113. #
  114. ############################################################################
  115.  
  116. ############################################################################
  117. #                                     #
  118. #           linfield:  line and field editing package         #
  119. #                                     #
  120. ############################################################################
  121. #
  122. #
  123. ############################################################################
  124. #                                     #
  125. # set of user defined functions essential to the line editor line()  #
  126. #                                     #
  127. ############################################################################
  128. #
  129. # newkey(): redirects keyboard to make some of the editing functions
  130. # accessable also by arrow/ctrl-arrow-keys. needs ansi.sys.
  131. # although newkey() isn't called by line() directly, a program
  132. # which uses line() should contain a call to newkey(), because
  133. # otherwise line()'S function won't be available for cursor keys.
  134.  
  135.     procedure newkey()
  136.  
  137.    local code, n_keys
  138.         n_keys := list(9)
  139. # arrow left (cursor left)
  140.         n_keys[1] := char(27) || "[0;77;1p"
  141. # arrow right (cursor right)
  142.         n_keys[2] := char(27) || "[0;75;2p"
  143. # arrow up (quit, decreasing line_number)
  144.         n_keys[3] := char(27) || "[0;72;14p"
  145. # arrow down (quit, increasing line_number)
  146.         n_keys[4] := char(27) || "[0;80;21p"
  147. # ctrl/left
  148.         n_keys[5] := char(27) || "[0;116;8p"
  149. # ctrl/right
  150.         n_keys[6] := char(27) || "[0;115;9p"
  151. # home
  152.         n_keys[7] := char(27) || "[0;71;4p"
  153. # end
  154.         n_keys[8] := char(27) || "[0;79;5p"
  155. # deL
  156.         n_keys[9] := char(27) || "[0;83;6p"
  157. #
  158. # activate codes
  159.     while code := get(n_keys) do {
  160.         writes(code)
  161.     }
  162. end
  163. #
  164. #
  165. # function to set cursor position
  166.     procedure locate(row,col)
  167.  
  168.    local cursor
  169.  
  170.         cursor := char(27) || "[" || row || ";" || col || "H"
  171.         writes(cursor)
  172. end
  173. #
  174. # last(byte,string): detects the last occurrence of byte in
  175. # string and returns its position
  176.     procedure last(byte,string)
  177.  
  178.    local a, r_string, rpos
  179.  
  180.         r_string := reverse(string)
  181.         rpos := find(byte,r_string)
  182.         a := (*string - rpos)
  183.         return a
  184. end
  185. #
  186. # remword(string,acol): removes word at acol from string
  187.     procedure remword(string,acol)
  188.  
  189.    local blank, string_a, string_b
  190.  
  191. # if acol points to end of string, don`t do anything
  192.         if acol + 1 > *string then return string
  193. # if acol points to a blank just remove the blank
  194.         if string[acol + 1] == " " then {
  195.             string ? {
  196.             string_a := tab(acol + 1)
  197.             move(1)
  198.             string_b := tab(0)
  199.             string := string_a || string_b
  200.             return string
  201.             }
  202.         }
  203. # else delete actual word
  204.         if acol = 0 then acol := 1
  205. # crack string into two parts
  206.         string ? {
  207.             string_a := tab(acol + 1)
  208.             string_b := tab(0)
  209.         }
  210. # check string_a for the last blank if any
  211.         if find(" ",string_a) then {
  212.             blank := last(" ",string_a)
  213.             string_a := string_a[1:blank + 1]
  214.         }
  215.         else string_a := ""
  216. # check string_b for the first blank if any
  217.         if blank := find(" ",string_b) then {
  218.             string_b := string_b[blank:*string_b + 1]
  219.         }
  220.         else string_b := ""
  221. # build string out of string_a ending at its last and string_b
  222. # beginning at its first blank.
  223.         string := string_a || string_b
  224.         if string[1] == " " then string[1] := ""
  225.         return string
  226. end
  227. #
  228. # stat_line: function to display a status line with the actual row
  229. # and column
  230.     procedure stat_line(column)
  231.         locate(24,1)
  232.         writes("LINE: ",lin_nm," COL: ",column,"  ","TIME: ",&clock,"    ")
  233. end
  234. #
  235. # global variable line_number to indicate the increase or decrease
  236. # of global variable lin_nm
  237.     global line_number
  238. #
  239. # global variable lin_nm to increase or decrease actual line
  240. # in the field
  241.     global lin_nm
  242. #
  243. # global variable field_flag: direction flag to increase or
  244. # decrease field number
  245.     global field_flag
  246. #
  247. # global variable item_flag: direction flag to increase or
  248. # decrease item number
  249.     global item_flag
  250. #
  251. ############################################################################
  252. #                                    #
  253. #               line editor line()                #
  254. #                                    #
  255. ############################################################################
  256. #
  257. # editing commands for the line editor:
  258. #        ctrl/A: byte forward (arrow right)
  259. #        ctrl/B: byte back (arrow left)
  260. #        ctrl/D: beginning of line (home)
  261. #        ctrl/E: end of line (end)
  262. #        ctrl/F: del byte (del)
  263. #        ctrl/G: del word
  264. #        ctrl/H: word forward (ctrl/right)
  265. #        ctrl/I: word back (ctrl/ left)
  266. #        ctrl/L: perform block operation
  267. #               1. press ctrl/L
  268. #               2. enter relative adress (followed by <ret>) for
  269. #               block end. It must be an (numerical) offset
  270. #               pointing right to the actual cursor.
  271. #               3.  enter "r" (no <ret>!) for remove or "b"
  272. #               to move block to the beginning of field
  273. #               or "e" to transfer it to the end.
  274. #            Annotation: "impossible" adresses (beyond string
  275. #            length or negative) will be ignored.
  276. #        alt/A : wrap line (+ 1)
  277. #        esc   : del line
  278. #        ctrl/K: restore line
  279. #        ctrl/n: quit line (- 1) (arrow up)
  280. #        ctrl/U: quit line (+ 1) (arrow down)
  281. #        ret   : quit line (+ 1)
  282. ############################################################################
  283. #
  284. # Function to edit a line. The function needs the following
  285. # arguments
  286. #        row    : (row of the line to be edited)
  287. #        bnumber: (maximum size of the string to be
  288. #             edited, further input will be
  289. #             ignored.)
  290. #        status:  display actual line_number and col2 if
  291. #             status == 1 else not
  292. #        comment: (comment or input prompt)
  293. #        field  : (contains the string to be edited.)
  294. #
  295. # The function returns a list with the first element containing
  296. # The main part of FIELD and the second element containing
  297. # the wrapped part if any.
  298. #
  299.     procedure line(row,bnumber,status,comment,field)
  300.  
  301.    local beg, blank, blanks, block, byte, byte_input, col, col2, dec_byte
  302.    local dec_bytes, e1, e2, editing, fa, fb, field2, field_1, field_2
  303.    local field_a, field_b, fieldl, highl, lg, mark, n_blank, nb, normal
  304.    local quit, r_field, rest
  305.  
  306. # Define csets containing the keys for
  307. #    input
  308. #    editing functions
  309. #    quit / wraP
  310. #
  311. # Characters permitted in the edited field
  312.     n_blank := &ucase ++ &lcase ++ &digits ++ 'äöüÄÖÜß?.,;!'
  313.     byte_input := n_blank ++ ' '
  314. # Characters for the editing functions
  315.     e1 := set([char(1),char(2),char(4),char(5),char(6),char(7),char(8)])
  316.     e2 := set([char(27),char(11)])
  317.     editing := e1 ++ e2
  318. # Characters to end editing
  319.     quit := set([char(13),char(30),char(14),char(21)])
  320. #
  321. # List to return result
  322.     fieldl := list()
  323. # Initialize field_a/b for a concatenation, if scanning field
  324. # fails
  325.    field_a := ""
  326.    field_b := ""
  327. # Initialize r_field (variable to store completely deleted field
  328. # to keep it recoverable)
  329.    r_field := ""
  330. # Codes to highlight screen output and to return to normal
  331. # screen outpuT
  332.    highl := char(27) || "[7m"
  333.    normal := char(27) || "[0m"
  334. #
  335. # Remove single initial blank if any
  336.         if field[1] == " " then {
  337.         field := field[2:(*field+1)]
  338.         }
  339. #
  340. # Display field when beginning the editing process, place
  341. # cursor behind the end of field
  342.         locate(row,1)
  343.         writes(comment,field,repl(" ",(bnumber-*field)))
  344. # If status is set to 1 display line_number and col2 after the
  345. # initial printing of line
  346.         if status == 1 then stat_line(*field+1)
  347. # col: absolute cursor position (comment and field)
  348. # col2: relative position in field
  349.         col := (*comment + *field) + 1
  350.         col2 := *field + 1
  351.         locate(row,col)
  352. #
  353. # Editing loop: continue until end character appears
  354.         while byte := getch() & not member(quit,byte) do {
  355.             if find(byte,byte_input) & *field <= bnumber - 2 then {
  356. # If byte is a normal character (if member(byte_input,byte)) insert
  357. # it into field at cursor position.
  358. #
  359.                 field ? {
  360.                 field_a := tab(col2)
  361.                 field_b := tab(0)
  362.                 }
  363.                 field := field_a || byte || field_b
  364.                 locate(row,1)
  365.                 writes(comment,field)
  366.                 col +:= 1
  367.                 col2 +:= 1
  368.                 if status == 1 then stat_line(col2)
  369.                 locate(row,col)
  370.             }
  371. # else perform editing operation
  372.             else  {
  373.                 case byte of {
  374. # backspace (ctrl/B)
  375.                 char(2) : if col2 > 1 then {
  376.                     col -:= 1
  377.                     col2 -:= 1
  378.                     if status == 1 then stat_line(col2)
  379.                     locate(row,col)
  380.                 }
  381. # byte forward (ctrl/A)
  382.                 char(1) : if col2 <= *field then {
  383.                     col +:= 1
  384.                     col2 +:= 1
  385.                     if status == 1 then stat_line(col2)
  386.                     locate(row,col)
  387.                 }
  388. # goto beginning of line (ctrl/D)
  389.                 char(4) : {
  390.                     col2 := 1
  391.                     col := *comment + col2
  392.                     if status == 1 then stat_line(col2)
  393.                     locate(row,col)
  394.                 }
  395. # goto end of line  (ctrl/E)
  396.                 char(5) : {
  397.                     col2 := (*field + 1)
  398.                     col := *comment + col2
  399.                     if status == 1 then stat_line(col2)
  400.                     locate(row,col)
  401.                 }
  402. # delete byte at cursor position (ctrl/F)
  403.                 char(6) : {
  404.                     if col2 <= *field then {
  405.                     field ? {
  406.                         beg := tab(col2)
  407.                         rest := tab(0)
  408.  
  409.                     }
  410.                      rest[1] := ""
  411.                      field := beg || rest
  412.                      locate(row,1)
  413.                      writes(comment,field," ")
  414.                      locate(row,col)
  415.                      }
  416.                 }
  417. #
  418. # delete the actual word (ctrl/G)
  419.                char(7) : {
  420.                 field2 := remword(field,col2 - 1)
  421.                 blanks := *field - *field2
  422.                 field := field2
  423.                 col2 := col2 - blanks
  424.                 if col2 <= 0 then col2 := 1
  425.                 col := *comment + col2
  426.                 locate(row,1)
  427.                 writes(comment,field,repl(" ",blanks))
  428.                 if status == 1 then stat_line(col2)
  429.                 locate(row,col)
  430.                }
  431.  
  432. # move to the beginning of the following word (ctrl/H)
  433.                 char(8) : {
  434.                     if find(" ",field[col2:*field]) then {
  435.                     string := field[col2:*field]
  436.                     blank := find(" ",string)
  437.                     col2 := col2 + blank
  438.                     col := *comment + col2
  439.                     if status == 1 then stat_line(col2)
  440.                     locate(row,col)
  441.                     }
  442.                 }
  443. #
  444. # move to the beginning of the recent word (ctrl/I)
  445.                 char(9) : {
  446. # jump over the blank preceding the actual word
  447.                   if col2 = 1 then locate(row,col)
  448.                   else {
  449.                     if find(" ",field[1:(col2 - 2)]) then {
  450.                     string := field[1:(col2 - 2)]
  451.                     col2 := (last(" ",string) + 2)
  452.                      }
  453.                      else {
  454.                     col2 := 1
  455.                      }
  456.                    col := *comment + col2
  457.                    if status == 1 then stat_line(col2)
  458.                    locate(row,col)
  459.                   }
  460.                 }
  461. #
  462. # Delete complete line, deleted line is assigned to r_field
  463. # to be recoverable
  464.                 char(27) : {
  465.                     lg := *field
  466.                     r_field := field
  467.                     field := ""
  468.                     col2 := 1
  469.                     col := *comment + col2
  470.                     locate(row,1)
  471.                     writes(comment,repl(" ",lg))
  472.                     if status == 1 then stat_line(col2)
  473.                     locate(row,col)
  474.                 }
  475. # Restore deleted line (overwrite new actual line, assigning it
  476. # to r_field)
  477.                   char(11) : {
  478.                   if *r_field >= 1 then {
  479.                       field :=: r_field
  480.                       col2 := *field + 1
  481.                       col := *comment + col2
  482.                       locate(row,1)
  483.                       blanks := bnumber - *field
  484.                       writes(comment,field,repl(" ",blanks))
  485.                       if status == 1 then stat_line(col2)
  486.                       locate(row,col)
  487.                   }
  488.                   }
  489.  
  490. # Perform block operation
  491.                   char(12) : {
  492.                   mark := ""
  493.                   dec_bytes := ""
  494.                   while nb := getch() & nb ~== char(13) do {
  495.                     mark ||:= nb
  496.                   }
  497.                   if mark < 1 then mark := 1
  498. # Place cursor to field's beginning if it points to its end
  499.                   if col2 >= *field then col2 := 1
  500.                   field ? {
  501.                     fa := tab(col2)
  502.                     block := move(mark)
  503.                     fb := tab(0)
  504.                   }
  505.                   locate(row,1)
  506.                   writes(comment,fa,highl,block,normal,fb)
  507.                   dec_byte := getch()
  508.                   if dec_byte == ("r" | "R") then {
  509.                       field := fa || fb
  510.                       locate(row,1)
  511.                       writes(comment,field,repl(" ",*block + 1))
  512.                       col2 := col2 - *block
  513.                       if col2 < 1 then col2 := 1
  514.                       col := *comment + col2
  515.                       if status == 1 then stat_line(col2)
  516.                       locate(row,col)
  517.                   }
  518.                   else {
  519.                        if dec_byte == ("b" | "B") then {
  520.                        field := block || fa || fb
  521.                        }
  522.                        if dec_byte == ("e" | "E") then {
  523.                        field := fa || fb || block
  524.                        locate(row,1)
  525.                        }
  526.                     locate(row,1)
  527.                     writes(comment,field)
  528.                     locate(row,col)
  529.                   }
  530.                   }
  531.  
  532. # right brace closing case control structure
  533.              }
  534. # right brace closing else structure (editing keys)
  535.         }
  536. # right brace closing while-do loop
  537.        }
  538. #
  539. # if while-do loop stops it must be because of a key in quit.
  540. # Therefore perform final operation and return.
  541. #
  542. # wrap: divide field at the last possible blank, assign the
  543. # first part to the first element of list result, the second
  544. # part to the second element.
  545.       if byte == char(30) & find(" ",field) then {
  546.           blank := last(" ",field)
  547.           field_1 := field[1:(blank + 1)]
  548.           field_2 := field[(blank + 2):(*field + 1)]
  549.           locate(row,(*comment + 1))
  550.           writes(field_1,repl(" ",*field_2))
  551.           put(fieldl,field_1)
  552.           put(fieldl,field_2)
  553. # Increase lnumber by 1
  554.           line_number := 1
  555. # Return list with main part and wrapped part as its elements
  556.           return fieldl
  557.       }
  558. #
  559. # normal termination by <ret> or <arrow down>
  560.     if byte == (char(13) | char(21)) then {
  561.           put(fieldl,field)
  562.           put(fieldl,"")
  563.           line_number := 1
  564.           return fieldl
  565.     }
  566. # normal termination by alt/e
  567.     else {
  568.         if byte == char(14) then {
  569.           put(fieldl,field)
  570.           put(fieldl,"")
  571.           line_number := -1
  572.           return fieldl
  573.         }
  574.     }
  575. end
  576. #
  577. ############################################################################
  578. #                                    #
  579. #             field editor edit_field()                #
  580. #                                    #
  581. ############################################################################
  582. #
  583. # edit_field: user-defined function to divide a long string into
  584. # lines and edit them as a field. uses: line() and all user-
  585. # defined functions called by line().
  586. # edit_field() accepts its data in a single string which is
  587. # cracked apart before editing and put together afterwards.
  588. # exceeding the size of the field (lnumber) by moving the
  589. # cursor out of it, finishes the editing process.
  590. #
  591. # Annotation: edit_field() doesn't contain anything needed
  592. # by line() and therefore should be removed if only line()
  593. # is to be used.
  594. #
  595. # arguments to the function:
  596. #    startline    : first line on the screen
  597. #    lnumber     : number of lines within field
  598. #    byte_n        : number of bytes permitted within a line
  599. #    label        : label to be displayed as field's headline
  600. #    string        : string to be edited
  601.     procedure edit_field(startline,lnumber,byte_n,label,string)
  602.  
  603.    local feld, item, lin, liste, n, res, rest
  604.  
  605. # Fail if "editing beyond the end of screen" is tried or byte_n is
  606. # too big
  607.         if {(lnumber + startline > 24)  | (byte_n > 77)} then {
  608.         write("ERROR: ILLEGAL ARGUMENT!")
  609.         fail
  610.         }
  611.         n := 1
  612. # Initialize feld as a list to contain string's contents
  613.         feld := list(lnumber,"")
  614. # Crack apart string into byte_n-byte items.
  615.         while lin := string[1:byte_n] do {
  616. # Assign every item's substring upto the last " " to field[n]
  617.         feld[n] := lin[1:last(" ",lin)+1]
  618. # Assign the rest to rest
  619.         rest := lin[(last(" ",lin)+2):*lin+1]
  620. # Delete the first byte_n bytes, then concatenate rest and string
  621.         string[1:byte_n] := ""
  622.         string := rest || string
  623.         n +:= 1
  624.         }
  625.         feld[n] := string
  626. # Display field's contents
  627.         n := 1
  628.         locate(startline-1,1)
  629.         writes(center(label,(byte_n-5)," "))
  630.         while n <= lnumber do {
  631.         locate(startline-1+n,1)
  632.         writes(feld[n])
  633.         n +:= 1
  634.         }
  635. # Begin editing process
  636.     line_number := 1
  637.     lin_nm := 1
  638. # Stop if access to non permitted line number (0,>lnumber) is
  639. # tried.
  640.     while lin_nm >= 1 & lin_nm <= lnumber do {
  641. #        locate(23,40)
  642. #        write("ZEILENTYP: ",type(startline))
  643. #        read()
  644.         liste := line(startline,byte_n,1,"▄ ",feld[lin_nm])
  645.         feld[lin_nm] := liste[1]
  646.         locate(startline,1)
  647.         writes(feld[lin_nm],repl(" ",byte_n-*feld[lin_nm]+1))
  648.         startline +:= line_number
  649.         lin_nm +:= line_number
  650. # If wrap demanded and the following line is capable to contain
  651. # the wrapped rest of the line before and its original content,
  652. # perform wrap.
  653.         if *liste[2] + *feld[lin_nm] <= byte_n then {
  654.         feld[lin_nm] := liste[2] || " " || feld[lin_nm]
  655.         }
  656.     }
  657. # Set flag field_flag to -1/1 to indicate the direction
  658. # in which the field has been quitted.
  659.     if lin_nm <= 1 then field_flag := -1
  660.     if lin_nm >= lnumber then field_flag := 1
  661. # Put the string to be returned together of feld's elements.
  662.     res := ""
  663.     while item := pop(feld) do {
  664.         res := res || " " || item
  665.     }
  666.     return res
  667. end
  668. #
  669. # show_field: see edit field (except editing routines) for
  670. # details.
  671.     procedure show_field(startline,lnumber,byte_n,label,string)
  672.  
  673.    local feld, lin, n, rest
  674.  
  675.         if {(lnumber + startline > 24)  | (byte_n > 77)} then {
  676.         write("ERROR: ILLEGAL ARGUMENT!")
  677.         fail
  678.         }
  679.         n := 1
  680.         feld := list(lnumber,"")
  681.         while lin := string[1:byte_n] do {
  682.         feld[n] := lin[1:last(" ",lin)+1]
  683.         rest := lin[(last(" ",lin)+2):*lin+1]
  684.         string[1:byte_n] := ""
  685.         string := rest || string
  686.         n +:= 1
  687.         }
  688.         feld[n] := string
  689.         n := 1
  690.         locate(startline-1,1)
  691.         writes(center(label,(byte_n-5)," "))
  692.         while n <= lnumber do {
  693.         locate(startline-1+n,1)
  694.         writes(feld[n])
  695.         n +:= 1
  696.         }
  697. end
  698. #
  699. # edit_item(): function to edit the entry concerning one item
  700. # of literature. This function makes it necessary to declare
  701. # a fixed structure of every item within the function
  702. # "#" separates the fields from each other. it shouldn't be
  703. # contained in the data given to edit_item().
  704. #
  705. # Structure of an item:
  706. #    TITLE
  707. #    AUTHOR
  708. #    YEAR
  709. #    TYPE
  710. #    COMMENT1
  711. #    COMMENT2
  712.     procedure edit_item(item)
  713.  
  714.    local ct, feld, felder, felder2, item2, labels, lin_e, n, zeile
  715.  
  716.         felder := list()
  717.         felder2 := list()
  718.         labels := ["AUTHOR","TITLE","YEAR","TYPE","COMMENT1","COMMENT2"]
  719.         item ? {
  720.         while feld := tab(upto("#")) do {
  721.             move(1)
  722.             put(felder,feld)
  723.             put(felder2,feld)
  724.         }
  725.         }
  726.         zeile := 2
  727. # Display the fields
  728.         n := 1
  729.         while feld := get(felder) do {
  730.         show_field(zeile,2,70,labels[n],feld)
  731.         n +:= 1
  732.         zeile +:= 4
  733.         }
  734. # Start editing process
  735.     ct := 1
  736.     zeile := 2
  737.     while zeile >= 2 & zeile <= 22 do {
  738.         felder2[ct] := edit_field(zeile,2,70,labels[ct],trim(felder2[ct]))
  739.         ct +:= field_flag
  740.         if field_flag = 1 then zeile +:= 4 else zeile -:= 4
  741.     }
  742. # Indicate the direction in which item has been quitted using
  743. # global variable item_flag
  744.     if zeile < 2 then item_flag := -1 else item_flag := 1
  745.     item2 := ""
  746. # Format result: item's fields are brought up to a standard length
  747. # of 140 bytes using blanks.
  748.     while lin_e := get(felder2) do {
  749.         item2 ||:= lin_e || repl(" ",(140 - *lin_e)) || "#"
  750.     }
  751.     return item2
  752. end
  753. #
  754. # brightwrite(string): function to highlight a string
  755.     procedure brightwrite(string)
  756.  
  757.    local highl, normal
  758.  
  759.         highl := char(27) || "[7m"
  760.         normal := char(27) || "[0m"
  761.         writes(highl,string,normal)
  762. end
  763. #
  764. # findlist(wlist,item): function to return the first
  765. # position of item in wlist.
  766.     procedure findlist(wlist,item)
  767.  
  768.    local n
  769.  
  770.     n := 1
  771.     while n <= *wlist do {
  772.         if wlist[n] == item then return n
  773.         n +:= 1
  774.     }
  775.     fail
  776. end
  777. #
  778. # menue(header,wlist,klist): function to build up a menuE
  779. # Arguments: header, list of options (wlist) and list of
  780. # shorthand keys (key list).
  781. # because menue() fails if a non defined key (not contained
  782. # in klist, no arrow key), calls to menue() should be made
  783. # within a loop terminated on menue()'s success, see below
  784. # main().
  785.     procedure menue(header,wlist,klist)
  786.  
  787.    local add, byte, n
  788.  
  789.         locate(4,10)
  790.         writes(header)
  791.         n := 5
  792.         while (n - 4) <= *wlist do {
  793.             locate(n,10)
  794.             writes(wlist[n-4])
  795.             n +:= 1
  796.         }
  797.         n := 5
  798.         locate(n,10)
  799.         brightwrite(wlist[n-4])
  800.         while byte := getch() & {
  801.              byte == (char(21) | char(14)) | findlist(klist,byte)
  802.          }
  803.         do {
  804. # If byte Is element of klist (shorthandkey) the element number
  805. # within the list + 4 indicates option.
  806.             if add := findlist(klist,byte) then {
  807.             locate(n,10)
  808.             writes(wlist[n-4])
  809.             n := 4 + add
  810.             locate(n,10)
  811.             brightwrite(wlist[n-4])
  812.             }
  813. # else increase/decrease actual element by one.
  814.             else {
  815.             if byte == char(14) then add := -1
  816.             if byte == char(21) then add := 1
  817.             locate(n,10)
  818.             writes(wlist[n-4])
  819.             n +:= add
  820.             if (n - 4) < 1 then n +:= 1
  821.             if (n - 4) > *wlist then n -:= 1
  822.             locate(n,10)
  823.             brightwrite(wlist[n-4])
  824.             }
  825.         }
  826.         if byte == char(13) then return wlist[(n-4)] else fail
  827. end
  828. #
  829. # in_itemm(): function to create new items. Standard file is literat.fil
  830. # The new items are handled as a sequential file which is added to the
  831. # existing file when input process is finished.
  832.     procedure in_itemm()
  833.  
  834.    local answer, count, items, itnum, out_item
  835.  
  836.         item_flag := 1
  837.         items := list(200,"######")
  838.         itnum := 0
  839.         repeat {
  840.              itnum +:= item_flag
  841.              if itnum < 1 then itnum := 1
  842.              items[itnum] := edit_item(items[itnum])
  843.              writes(char(27),"[2J")
  844.              write("NEW ITEM? Yy/Nn!")
  845.              answer := getch()
  846.              if answer == ("n" | "N") then break
  847.         }
  848.         count := 1
  849.         out_item := open("literat.fil","a")
  850.         while items[count] ~== "######" do {
  851.             writes(out_item,items[count])
  852.             count +:= 1
  853.         }
  854.         close(out_item)
  855. end
  856. #
  857. # turn_over(): view and edit literat.fil item by item
  858.     procedure turn_over()
  859.  
  860.    local answer, in_item, it, out_item
  861.  
  862.         in_item := open("literat.fil","r")
  863.         out_item := open("literat2.fil","w")
  864.         repeat {
  865.             it := reads(in_item,846)
  866.             it := edit_item(it)
  867.             writes(out_item,it)
  868.             writes(char(27),"[2J")
  869.             write("NEW ITEM? Yy/Nn!")
  870.             answer := getch()
  871.             if answer == ("n" | "N") then break
  872. # If item_flag is -1 seek -1692 (2 items) to access the beginning of the
  873. # previous item because the internal file pointer points to the end of
  874. # the actual item.
  875.             if item_flag == -1 then seek(in_item,where(in_item)-1692)
  876.         }
  877.         close(in_item)
  878.         close(out_item)
  879. end
  880. #
  881. # del(num) remove numth item from filE
  882.     procedure del()
  883.  
  884.    local fil, in_item, itm, n, num, out_item
  885.  
  886.         writes(char(27),"[2J")
  887.         write("NUMBER OF ITEM TO BE REMOVED?")
  888.         num := read()
  889.         write("READING...")
  890.         fil := list()
  891.         in_item := open("literat.fil","r")
  892.         while itm := reads(in_item,846) do {
  893.         put(fil,itm)
  894.         }
  895.         close(in_item)
  896.         write("START OVERWRITE PROCESS...")
  897.         n := num
  898.         while n < *fil do {
  899.         fil[n] := fil[n+1]
  900.         n +:= 1
  901.         }
  902.         fil[*fil] := ""
  903.         out_item := open("literat2.fil","w")
  904.         write("WRITING...")
  905.         while itm := get(fil) & itm ~== "" do {
  906.         writes(out_item,itm)
  907.         }
  908.         close(out_item)
  909.         write("DONE...")
  910. end
  911. #
  912. # alpha: sorting in alphabetical order
  913.     procedure alpha()
  914.  
  915.    local fil, in_item, itm, out_item
  916.  
  917.     writes(char(27),"[2J")
  918.     write("READING...")
  919.     fil := list()
  920.     in_item := open("literat.fil","r")
  921.     while itm := reads(in_item,846) do {
  922.         put(fil,itm)
  923.     }
  924.     close(in_item)
  925.     write("ARRANGING DATA IN ALPHABETICAL ORDER...")
  926.     fil := sort(fil)
  927.     write("WRITING...")
  928.     out_item := open("literat2.fil","w")
  929.     while itm := get(fil) & itm ~== "" do {
  930.         writes(out_item,itm)
  931.     }
  932.     close(out_item)
  933.     write("DONE...")
  934. end
  935. #
  936. # m_adress: function to generate a file with arguments to the seek()
  937. # function. The file (adress.fil) will be used for sequential
  938. # search in the computer's ram, (function (query()). The results enable
  939. # the seek() function to place the internal file pointer on the desired
  940. # item in literat.fil.
  941.     procedure m_adress()
  942.  
  943.    local a, adr, b, in_item, item, m, n, out_adr, out_line, wlist, wlist_2
  944.  
  945.         out_line := ""
  946.         adr := edit_field(4,10,70,"FORMAT: <WORD>;<WORD>;ETC.","")
  947.         writes(char(27),"[2J")
  948.         write("GENERATING WORD LIST...")
  949.         wlist := list()
  950.         n := 1
  951.         adr ? {
  952.             while put(wlist,tab(upto(";"))) do {
  953.             move(1)
  954.             write("ACTUAL WORD: ",wlist[n])
  955.             n +:= 1
  956.             }
  957.         }
  958.         in_item := open("literat.fil","r")
  959.         n := 1
  960.  
  961.         wlist_2 := copy(wlist)
  962. # Insert ; between word in wlist_2 and seqence of record numbers
  963. # to be found out later.
  964.         while n <= *wlist_2 do {
  965.             wlist_2[n] ||:= ";"
  966.              n +:= 1
  967.         }
  968.         n := 1
  969.         while n <= *wlist do {
  970.             write("COMPARING WORD NUMBER: ",n,".")
  971. # counter m: indicates record number
  972.             m := 1
  973.             while item := reads(in_item,846) do {
  974.             if find(wlist[n],item) then {
  975.                 wlist_2[n] ||:= m || ";"
  976.             }
  977.             m +:= 1
  978.             }
  979.             wlist_2[n] ? {
  980.             a := tab(upto(";"))
  981.             b := tab(0)
  982.             }
  983.             if b == ";" then b := ";0"
  984.             wlist_2[n] := a || b
  985.             out_line ||:= wlist_2[n] || ":"
  986. # When every item has been compared with wlist[n], move file
  987. # pointer to the beginning of in_item and increase n by 1.
  988.             seek(in_item,1)
  989.             n +:= 1
  990.         }
  991.         close(in_item)
  992. # Remove trailing blank if any
  993.         if out_line[1] := " " then {
  994.             out_line := out_line[2:(*out_line+1)]
  995.         }
  996.         write("WRITING ADRESS FILE")
  997.         out_adr := open("adress.fil","a")
  998.         writes(out_adr,out_line)
  999.         close(out_adr)
  1000.         write("OK")
  1001. end
  1002. #
  1003. # query(): find items using the numbers in adress.fil * 846 as
  1004. # arguments to the seek() function
  1005.     procedure query()
  1006.  
  1007.    local byte, in_item, in_line, in_query, it_key, kkey, out_item, word, wrd
  1008.  
  1009.         writes(char(27),"[2J")
  1010.         in_query := open("adress.fil","r")
  1011.         in_line := read(in_query)
  1012.         close(in_query)
  1013.         in_item := open("literat.fil","r")
  1014.         out_item := open("literat2.fil","a")
  1015.         wrd := line(10,20,0,"TYPE WORD TO BE LOOKED FOR: ","")
  1016.         word := wrd[1]
  1017.         if byte := find(word,in_line) then {
  1018.         in_line ? {
  1019.             move(byte)
  1020.             it_key := tab(upto(":"))
  1021.         }
  1022.          }
  1023.          else {
  1024.          locate(10,25)
  1025.          writes("ERROR: UNKNOWN WORD! PRESS KEY!")
  1026.          getch()
  1027.          fail
  1028.          }
  1029. # place internal cursor behind the first ; to get the first
  1030. # number:
  1031.          it_key := it_key[find(";",it_key)+1:*it_key+1]
  1032.          it_key ? {
  1033.          while kkey := tab(upto(";")) do {
  1034.              if kkey <= 0 then {
  1035.             locate(10,25)
  1036.             writes("ERROR: UNKNOWN WORD! PRESS KEY!")
  1037.             getch()
  1038.             fail
  1039.              }
  1040.              seek(in_item,(kkey-1)*846)
  1041.              writes(out_item,edit_item(reads(in_item,846)))
  1042.              move(1)
  1043.          }
  1044.          }
  1045.          close(in_item)
  1046.          close(out_item)
  1047.          write("OK")
  1048. end
  1049. #
  1050. # main program. see the description of the program's functionS
  1051. # at the beginning of the source code and of every user-defined
  1052. # function if you are in doubt how to use them.
  1053. #
  1054.     procedure main()
  1055.  
  1056.     local alist, blist, opt
  1057.  
  1058.     newkey()
  1059.     alist := {
  1060.     ["iNPUT","tURN OVER ITEMS","aDRESS FILE","qUERY","dEL","AlPHA","eND"]
  1061.     }
  1062.     blist := ["i","t","a","q","d","l","e"]
  1063.     repeat {
  1064.       repeat {
  1065.     writes(char(27),"[2J")
  1066.     locate(1,10)
  1067.     write("LITERAT:    EASY DATABASE SYSTEM")
  1068.     locate(2,10)
  1069.     write("WRITTEN BY: MATTHIAS HEESCH 1992")
  1070.     if opt := menue("MENUE",alist,blist) then break
  1071.       }
  1072.       writes(char(27),"[2J")
  1073.       case opt of {
  1074.     "iNPUT" : in_itemm()
  1075.     "tURN OVER ITEMS" : turn_over()
  1076.     "aDRESS FILE" : m_adress()
  1077.     "qUERY" : query()
  1078.     "dEL" : del()
  1079.     "AlPHA" : alpha()
  1080.     "eND" : break
  1081.       }
  1082.     }
  1083. end
  1084.