diff options
Diffstat (limited to 'ipl/progs/literat.icn')
| -rw-r--r-- | ipl/progs/literat.icn | 1083 |
1 files changed, 1083 insertions, 0 deletions
diff --git a/ipl/progs/literat.icn b/ipl/progs/literat.icn new file mode 100644 index 0000000..fde9c5c --- /dev/null +++ b/ipl/progs/literat.icn @@ -0,0 +1,1083 @@ +############################################################################ +# +# File: literat.icn +# +# Subject: Program to manage literature information +# +# Author: Matthias Heesch +# +# Date: March 26, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Database system to manage information concerning literature. +# +############################################################################ +# +# Written by: Dr. Matthias Heesch +# Department of Protestant Theology (FB 02) +# Johannes Gutenberg University +# Saarstrasse 21 / D-W-6500 Mainz 1 / Germany +# +############################################################################ +# +# Written and tested under: DR/MS-DOS, using ansi.sys +# +############################################################################ +# +# See the comment lines concerning the single user defined +# functions if you want to use them separately. Note that all screen +# access assumes ansi.sys to be installed. +# +# Since arguments to the seek() function may be long integers, +# long-integer support is required. +# +# The program uses standard files literat.fil, literat2.fil and +# adress.fil to store its data on the disk. It has a predefined +# structure of the items and predefined field labels to make it easy +# to use and to cut down the source code length.for users having some +# knowledge of the Icon language it shouldn't be difficult to +# change the program. In this case the item length (now 846 byte) +# the option lists in menue() and the field label list have to be +# modified. The main changes then will concern user defined +# function edit_item() where the number of fields within an item +# is decided by *labels. In function in_itemm() the number of dummy +# field separators has to be equal to the amount of fields desired. +# (items := list(200,"##" if two fields are desired). Within the +# other functions only the amount of bytes for a whole item within +# reads() and seek() operation has to be changed accordingly. Note +# that "literat"'s editor in its present version isn't able to scroll. +# +# See the description (comment lines) of user defined function +# line() for details of the editing facilities. +# +# The menue accepts input by <arrow up/dn> and the lower case short +# hand key of every option. The selected option has to be activated +# by <ret>. +# +# iNPUT: function to update an existing file literat.dat. When moving +# the cursor out of the actual item, the last or following item will +# be displayed and is available for the editing process. Input treats +# literat.dat as a sequential file. Only the items to be added to the +# existing file are in the computer's memory. This fastens the option +# to switch between the (new) items. Otherwise it would have been +# necessary to load the whole literat.dat into the RAM or to load +# every new item from the disk. The first would consume too much +# memory with the result of potential loss of new items, the second +# would cost much time. In one session "literat" can accept no more +# than 200 new items. +# +# tURN_OVER_ITEMS: literat.dat can be viewed and edited item by item +# moving the cursor out of the actual item causes the next/last item +# to be displayed. The edited items are written to file literat2.fil +# +# aDRESS file: type words to be indicated. If they are found, the +# item numbers of their occurrence will be recorded in file adress.fil. +# Moving the cursor out of the editor causes the indicating +# process to start. New items to adress.fil are simply added to the +# file. Therefore changes of existing material in adress.fil have to +# be made by creating a new adress.fil. +# +# qUERY: searches item using the information in adress.fil. You are +# prompted to type a word and if it's found in adress.fil the +# programm will use the item numbers to compute arguments to the +# seek()-function and then read the item. After viewing and if +# desired editing the item it will be written to file literat2.fil. +# +# dEL: prompts for an item number and removes the corresponding item. +# the file then is written to literat2.fil, literat.fil remains +# as it was. +# +# AlPHA: alphabetical sorting, sorted file written to literat2.fil. +# +# eND: return to the operating system. +# +############################################################################ +# +# Important message to the user: everybody who will find and remove +# a bug or add any improvement to the program is kindly encouraged +# to send a copy to the above address. +# +############################################################################ +# +# Note: Clerical edits were made to this file by the Icon Project. +# It's possible they introduced errors. +# +############################################################################ +# +# Requires: large-integer arithmetic, ANSI terminal support +# +############################################################################ + +############################################################################ +# # +# linfield: line and field editing package # +# # +############################################################################ +# +# +############################################################################ +# # +# set of user defined functions essential to the line editor line() # +# # +############################################################################ +# +# newkey(): redirects keyboard to make some of the editing functions +# accessable also by arrow/ctrl-arrow-keys. needs ansi.sys. +# although newkey() isn't called by line() directly, a program +# which uses line() should contain a call to newkey(), because +# otherwise line()'S function won't be available for cursor keys. + + procedure newkey() + + local code, n_keys + n_keys := list(9) +# arrow left (cursor left) + n_keys[1] := char(27) || "[0;77;1p" +# arrow right (cursor right) + n_keys[2] := char(27) || "[0;75;2p" +# arrow up (quit, decreasing line_number) + n_keys[3] := char(27) || "[0;72;14p" +# arrow down (quit, increasing line_number) + n_keys[4] := char(27) || "[0;80;21p" +# ctrl/left + n_keys[5] := char(27) || "[0;116;8p" +# ctrl/right + n_keys[6] := char(27) || "[0;115;9p" +# home + n_keys[7] := char(27) || "[0;71;4p" +# end + n_keys[8] := char(27) || "[0;79;5p" +# deL + n_keys[9] := char(27) || "[0;83;6p" +# +# activate codes + while code := get(n_keys) do { + writes(code) + } +end +# +# +# function to set cursor position + procedure locate(row,col) + + local cursor + + cursor := char(27) || "[" || row || ";" || col || "H" + writes(cursor) +end +# +# last(byte,string): detects the last occurrence of byte in +# string and returns its position + procedure last(byte,string) + + local a, r_string, rpos + + r_string := reverse(string) + rpos := find(byte,r_string) + a := (*string - rpos) + return a +end +# +# remword(string,acol): removes word at acol from string + procedure remword(string,acol) + + local blank, string_a, string_b + +# if acol points to end of string, don`t do anything + if acol + 1 > *string then return string +# if acol points to a blank just remove the blank + if string[acol + 1] == " " then { + string ? { + string_a := tab(acol + 1) + move(1) + string_b := tab(0) + string := string_a || string_b + return string + } + } +# else delete actual word + if acol = 0 then acol := 1 +# crack string into two parts + string ? { + string_a := tab(acol + 1) + string_b := tab(0) + } +# check string_a for the last blank if any + if find(" ",string_a) then { + blank := last(" ",string_a) + string_a := string_a[1:blank + 1] + } + else string_a := "" +# check string_b for the first blank if any + if blank := find(" ",string_b) then { + string_b := string_b[blank:*string_b + 1] + } + else string_b := "" +# build string out of string_a ending at its last and string_b +# beginning at its first blank. + string := string_a || string_b + if string[1] == " " then string[1] := "" + return string +end +# +# stat_line: function to display a status line with the actual row +# and column + procedure stat_line(column) + locate(24,1) + writes("LINE: ",lin_nm," COL: ",column," ","TIME: ",&clock," ") +end +# +# global variable line_number to indicate the increase or decrease +# of global variable lin_nm + global line_number +# +# global variable lin_nm to increase or decrease actual line +# in the field + global lin_nm +# +# global variable field_flag: direction flag to increase or +# decrease field number + global field_flag +# +# global variable item_flag: direction flag to increase or +# decrease item number + global item_flag +# +############################################################################ +# # +# line editor line() # +# # +############################################################################ +# +# editing commands for the line editor: +# ctrl/A: byte forward (arrow right) +# ctrl/B: byte back (arrow left) +# ctrl/D: beginning of line (home) +# ctrl/E: end of line (end) +# ctrl/F: del byte (del) +# ctrl/G: del word +# ctrl/H: word forward (ctrl/right) +# ctrl/I: word back (ctrl/ left) +# ctrl/L: perform block operation +# 1. press ctrl/L +# 2. enter relative adress (followed by <ret>) for +# block end. It must be an (numerical) offset +# pointing right to the actual cursor. +# 3. enter "r" (no <ret>!) for remove or "b" +# to move block to the beginning of field +# or "e" to transfer it to the end. +# Annotation: "impossible" adresses (beyond string +# length or negative) will be ignored. +# alt/A : wrap line (+ 1) +# esc : del line +# ctrl/K: restore line +# ctrl/n: quit line (- 1) (arrow up) +# ctrl/U: quit line (+ 1) (arrow down) +# ret : quit line (+ 1) +############################################################################ +# +# Function to edit a line. The function needs the following +# arguments +# row : (row of the line to be edited) +# bnumber: (maximum size of the string to be +# edited, further input will be +# ignored.) +# status: display actual line_number and col2 if +# status == 1 else not +# comment: (comment or input prompt) +# field : (contains the string to be edited.) +# +# The function returns a list with the first element containing +# The main part of FIELD and the second element containing +# the wrapped part if any. +# + procedure line(row,bnumber,status,comment,field) + + local beg, blank, blanks, block, byte, byte_input, col, col2, dec_byte + local dec_bytes, e1, e2, editing, fa, fb, field2, field_1, field_2 + local field_a, field_b, fieldl, highl, lg, mark, n_blank, nb, normal + local quit, r_field, rest + +# Define csets containing the keys for +# input +# editing functions +# quit / wraP +# +# Characters permitted in the edited field + n_blank := &ucase ++ &lcase ++ &digits ++ '?.,;!' + byte_input := n_blank ++ ' ' +# Characters for the editing functions + e1 := set([char(1),char(2),char(4),char(5),char(6),char(7),char(8)]) + e2 := set([char(27),char(11)]) + editing := e1 ++ e2 +# Characters to end editing + quit := set([char(13),char(30),char(14),char(21)]) +# +# List to return result + fieldl := list() +# Initialize field_a/b for a concatenation, if scanning field +# fails + field_a := "" + field_b := "" +# Initialize r_field (variable to store completely deleted field +# to keep it recoverable) + r_field := "" +# Codes to highlight screen output and to return to normal +# screen outpuT + highl := char(27) || "[7m" + normal := char(27) || "[0m" +# +# Remove single initial blank if any + if field[1] == " " then { + field := field[2:(*field+1)] + } +# +# Display field when beginning the editing process, place +# cursor behind the end of field + locate(row,1) + writes(comment,field,repl(" ",(bnumber-*field))) +# If status is set to 1 display line_number and col2 after the +# initial printing of line + if status == 1 then stat_line(*field+1) +# col: absolute cursor position (comment and field) +# col2: relative position in field + col := (*comment + *field) + 1 + col2 := *field + 1 + locate(row,col) +# +# Editing loop: continue until end character appears + while byte := getch() & not member(quit,byte) do { + if find(byte,byte_input) & *field <= bnumber - 2 then { +# If byte is a normal character (if member(byte_input,byte)) insert +# it into field at cursor position. +# + field ? { + field_a := tab(col2) + field_b := tab(0) + } + field := field_a || byte || field_b + locate(row,1) + writes(comment,field) + col +:= 1 + col2 +:= 1 + if status == 1 then stat_line(col2) + locate(row,col) + } +# else perform editing operation + else { + case byte of { +# backspace (ctrl/B) + char(2) : if col2 > 1 then { + col -:= 1 + col2 -:= 1 + if status == 1 then stat_line(col2) + locate(row,col) + } +# byte forward (ctrl/A) + char(1) : if col2 <= *field then { + col +:= 1 + col2 +:= 1 + if status == 1 then stat_line(col2) + locate(row,col) + } +# goto beginning of line (ctrl/D) + char(4) : { + col2 := 1 + col := *comment + col2 + if status == 1 then stat_line(col2) + locate(row,col) + } +# goto end of line (ctrl/E) + char(5) : { + col2 := (*field + 1) + col := *comment + col2 + if status == 1 then stat_line(col2) + locate(row,col) + } +# delete byte at cursor position (ctrl/F) + char(6) : { + if col2 <= *field then { + field ? { + beg := tab(col2) + rest := tab(0) + + } + rest[1] := "" + field := beg || rest + locate(row,1) + writes(comment,field," ") + locate(row,col) + } + } +# +# delete the actual word (ctrl/G) + char(7) : { + field2 := remword(field,col2 - 1) + blanks := *field - *field2 + field := field2 + col2 := col2 - blanks + if col2 <= 0 then col2 := 1 + col := *comment + col2 + locate(row,1) + writes(comment,field,repl(" ",blanks)) + if status == 1 then stat_line(col2) + locate(row,col) + } + +# move to the beginning of the following word (ctrl/H) + char(8) : { + if find(" ",field[col2:*field]) then { + string := field[col2:*field] + blank := find(" ",string) + col2 := col2 + blank + col := *comment + col2 + if status == 1 then stat_line(col2) + locate(row,col) + } + } +# +# move to the beginning of the recent word (ctrl/I) + char(9) : { +# jump over the blank preceding the actual word + if col2 = 1 then locate(row,col) + else { + if find(" ",field[1:(col2 - 2)]) then { + string := field[1:(col2 - 2)] + col2 := (last(" ",string) + 2) + } + else { + col2 := 1 + } + col := *comment + col2 + if status == 1 then stat_line(col2) + locate(row,col) + } + } +# +# Delete complete line, deleted line is assigned to r_field +# to be recoverable + char(27) : { + lg := *field + r_field := field + field := "" + col2 := 1 + col := *comment + col2 + locate(row,1) + writes(comment,repl(" ",lg)) + if status == 1 then stat_line(col2) + locate(row,col) + } +# Restore deleted line (overwrite new actual line, assigning it +# to r_field) + char(11) : { + if *r_field >= 1 then { + field :=: r_field + col2 := *field + 1 + col := *comment + col2 + locate(row,1) + blanks := bnumber - *field + writes(comment,field,repl(" ",blanks)) + if status == 1 then stat_line(col2) + locate(row,col) + } + } + +# Perform block operation + char(12) : { + mark := "" + dec_bytes := "" + while nb := getch() & nb ~== char(13) do { + mark ||:= nb + } + if mark < 1 then mark := 1 +# Place cursor to field's beginning if it points to its end + if col2 >= *field then col2 := 1 + field ? { + fa := tab(col2) + block := move(mark) + fb := tab(0) + } + locate(row,1) + writes(comment,fa,highl,block,normal,fb) + dec_byte := getch() + if dec_byte == ("r" | "R") then { + field := fa || fb + locate(row,1) + writes(comment,field,repl(" ",*block + 1)) + col2 := col2 - *block + if col2 < 1 then col2 := 1 + col := *comment + col2 + if status == 1 then stat_line(col2) + locate(row,col) + } + else { + if dec_byte == ("b" | "B") then { + field := block || fa || fb + } + if dec_byte == ("e" | "E") then { + field := fa || fb || block + locate(row,1) + } + locate(row,1) + writes(comment,field) + locate(row,col) + } + } + +# right brace closing case control structure + } +# right brace closing else structure (editing keys) + } +# right brace closing while-do loop + } +# +# if while-do loop stops it must be because of a key in quit. +# Therefore perform final operation and return. +# +# wrap: divide field at the last possible blank, assign the +# first part to the first element of list result, the second +# part to the second element. + if byte == char(30) & find(" ",field) then { + blank := last(" ",field) + field_1 := field[1:(blank + 1)] + field_2 := field[(blank + 2):(*field + 1)] + locate(row,(*comment + 1)) + writes(field_1,repl(" ",*field_2)) + put(fieldl,field_1) + put(fieldl,field_2) +# Increase lnumber by 1 + line_number := 1 +# Return list with main part and wrapped part as its elements + return fieldl + } +# +# normal termination by <ret> or <arrow down> + if byte == (char(13) | char(21)) then { + put(fieldl,field) + put(fieldl,"") + line_number := 1 + return fieldl + } +# normal termination by alt/e + else { + if byte == char(14) then { + put(fieldl,field) + put(fieldl,"") + line_number := -1 + return fieldl + } + } +end +# +############################################################################ +# # +# field editor edit_field() # +# # +############################################################################ +# +# edit_field: user-defined function to divide a long string into +# lines and edit them as a field. uses: line() and all user- +# defined functions called by line(). +# edit_field() accepts its data in a single string which is +# cracked apart before editing and put together afterwards. +# exceeding the size of the field (lnumber) by moving the +# cursor out of it, finishes the editing process. +# +# Annotation: edit_field() doesn't contain anything needed +# by line() and therefore should be removed if only line() +# is to be used. +# +# arguments to the function: +# startline : first line on the screen +# lnumber : number of lines within field +# byte_n : number of bytes permitted within a line +# label : label to be displayed as field's headline +# string : string to be edited + procedure edit_field(startline,lnumber,byte_n,label,string) + + local feld, item, lin, liste, n, res, rest + +# Fail if "editing beyond the end of screen" is tried or byte_n is +# too big + if {(lnumber + startline > 24) | (byte_n > 77)} then { + write("ERROR: ILLEGAL ARGUMENT!") + fail + } + n := 1 +# Initialize feld as a list to contain string's contents + feld := list(lnumber,"") +# Crack apart string into byte_n-byte items. + while lin := string[1:byte_n] do { +# Assign every item's substring upto the last " " to field[n] + feld[n] := lin[1:last(" ",lin)+1] +# Assign the rest to rest + rest := lin[(last(" ",lin)+2):*lin+1] +# Delete the first byte_n bytes, then concatenate rest and string + string[1:byte_n] := "" + string := rest || string + n +:= 1 + } + feld[n] := string +# Display field's contents + n := 1 + locate(startline-1,1) + writes(center(label,(byte_n-5)," ")) + while n <= lnumber do { + locate(startline-1+n,1) + writes(feld[n]) + n +:= 1 + } +# Begin editing process + line_number := 1 + lin_nm := 1 +# Stop if access to non permitted line number (0,>lnumber) is +# tried. + while lin_nm >= 1 & lin_nm <= lnumber do { +# locate(23,40) +# write("ZEILENTYP: ",type(startline)) +# read() + liste := line(startline,byte_n,1," ",feld[lin_nm]) + feld[lin_nm] := liste[1] + locate(startline,1) + writes(feld[lin_nm],repl(" ",byte_n-*feld[lin_nm]+1)) + startline +:= line_number + lin_nm +:= line_number +# If wrap demanded and the following line is capable to contain +# the wrapped rest of the line before and its original content, +# perform wrap. + if *liste[2] + *feld[lin_nm] <= byte_n then { + feld[lin_nm] := liste[2] || " " || feld[lin_nm] + } + } +# Set flag field_flag to -1/1 to indicate the direction +# in which the field has been quitted. + if lin_nm <= 1 then field_flag := -1 + if lin_nm >= lnumber then field_flag := 1 +# Put the string to be returned together of feld's elements. + res := "" + while item := pop(feld) do { + res := res || " " || item + } + return res +end +# +# show_field: see edit field (except editing routines) for +# details. + procedure show_field(startline,lnumber,byte_n,label,string) + + local feld, lin, n, rest + + if {(lnumber + startline > 24) | (byte_n > 77)} then { + write("ERROR: ILLEGAL ARGUMENT!") + fail + } + n := 1 + feld := list(lnumber,"") + while lin := string[1:byte_n] do { + feld[n] := lin[1:last(" ",lin)+1] + rest := lin[(last(" ",lin)+2):*lin+1] + string[1:byte_n] := "" + string := rest || string + n +:= 1 + } + feld[n] := string + n := 1 + locate(startline-1,1) + writes(center(label,(byte_n-5)," ")) + while n <= lnumber do { + locate(startline-1+n,1) + writes(feld[n]) + n +:= 1 + } +end +# +# edit_item(): function to edit the entry concerning one item +# of literature. This function makes it necessary to declare +# a fixed structure of every item within the function +# "#" separates the fields from each other. it shouldn't be +# contained in the data given to edit_item(). +# +# Structure of an item: +# TITLE +# AUTHOR +# YEAR +# TYPE +# COMMENT1 +# COMMENT2 + procedure edit_item(item) + + local ct, feld, felder, felder2, item2, labels, lin_e, n, zeile + + felder := list() + felder2 := list() + labels := ["AUTHOR","TITLE","YEAR","TYPE","COMMENT1","COMMENT2"] + item ? { + while feld := tab(upto("#")) do { + move(1) + put(felder,feld) + put(felder2,feld) + } + } + zeile := 2 +# Display the fields + n := 1 + while feld := get(felder) do { + show_field(zeile,2,70,labels[n],feld) + n +:= 1 + zeile +:= 4 + } +# Start editing process + ct := 1 + zeile := 2 + while zeile >= 2 & zeile <= 22 do { + felder2[ct] := edit_field(zeile,2,70,labels[ct],trim(felder2[ct])) + ct +:= field_flag + if field_flag = 1 then zeile +:= 4 else zeile -:= 4 + } +# Indicate the direction in which item has been quitted using +# global variable item_flag + if zeile < 2 then item_flag := -1 else item_flag := 1 + item2 := "" +# Format result: item's fields are brought up to a standard length +# of 140 bytes using blanks. + while lin_e := get(felder2) do { + item2 ||:= lin_e || repl(" ",(140 - *lin_e)) || "#" + } + return item2 +end +# +# brightwrite(string): function to highlight a string + procedure brightwrite(string) + + local highl, normal + + highl := char(27) || "[7m" + normal := char(27) || "[0m" + writes(highl,string,normal) +end +# +# findlist(wlist,item): function to return the first +# position of item in wlist. + procedure findlist(wlist,item) + + local n + + n := 1 + while n <= *wlist do { + if wlist[n] == item then return n + n +:= 1 + } + fail +end +# +# menue(header,wlist,klist): function to build up a menuE +# Arguments: header, list of options (wlist) and list of +# shorthand keys (key list). +# because menue() fails if a non defined key (not contained +# in klist, no arrow key), calls to menue() should be made +# within a loop terminated on menue()'s success, see below +# main(). + procedure menue(header,wlist,klist) + + local add, byte, n + + locate(4,10) + writes(header) + n := 5 + while (n - 4) <= *wlist do { + locate(n,10) + writes(wlist[n-4]) + n +:= 1 + } + n := 5 + locate(n,10) + brightwrite(wlist[n-4]) + while byte := getch() & { + byte == (char(21) | char(14)) | findlist(klist,byte) + } + do { +# If byte Is element of klist (shorthandkey) the element number +# within the list + 4 indicates option. + if add := findlist(klist,byte) then { + locate(n,10) + writes(wlist[n-4]) + n := 4 + add + locate(n,10) + brightwrite(wlist[n-4]) + } +# else increase/decrease actual element by one. + else { + if byte == char(14) then add := -1 + if byte == char(21) then add := 1 + locate(n,10) + writes(wlist[n-4]) + n +:= add + if (n - 4) < 1 then n +:= 1 + if (n - 4) > *wlist then n -:= 1 + locate(n,10) + brightwrite(wlist[n-4]) + } + } + if byte == char(13) then return wlist[(n-4)] else fail +end +# +# in_itemm(): function to create new items. Standard file is literat.fil +# The new items are handled as a sequential file which is added to the +# existing file when input process is finished. + procedure in_itemm() + + local answer, count, items, itnum, out_item + + item_flag := 1 + items := list(200,"######") + itnum := 0 + repeat { + itnum +:= item_flag + if itnum < 1 then itnum := 1 + items[itnum] := edit_item(items[itnum]) + writes(char(27),"[2J") + write("NEW ITEM? Yy/Nn!") + answer := getch() + if answer == ("n" | "N") then break + } + count := 1 + out_item := open("literat.fil","a") + while items[count] ~== "######" do { + writes(out_item,items[count]) + count +:= 1 + } + close(out_item) +end +# +# turn_over(): view and edit literat.fil item by item + procedure turn_over() + + local answer, in_item, it, out_item + + in_item := open("literat.fil","r") + out_item := open("literat2.fil","w") + repeat { + it := reads(in_item,846) + it := edit_item(it) + writes(out_item,it) + writes(char(27),"[2J") + write("NEW ITEM? Yy/Nn!") + answer := getch() + if answer == ("n" | "N") then break +# If item_flag is -1 seek -1692 (2 items) to access the beginning of the +# previous item because the internal file pointer points to the end of +# the actual item. + if item_flag == -1 then seek(in_item,where(in_item)-1692) + } + close(in_item) + close(out_item) +end +# +# del(num) remove numth item from filE + procedure del() + + local fil, in_item, itm, n, num, out_item + + writes(char(27),"[2J") + write("NUMBER OF ITEM TO BE REMOVED?") + num := read() + write("READING...") + fil := list() + in_item := open("literat.fil","r") + while itm := reads(in_item,846) do { + put(fil,itm) + } + close(in_item) + write("START OVERWRITE PROCESS...") + n := num + while n < *fil do { + fil[n] := fil[n+1] + n +:= 1 + } + fil[*fil] := "" + out_item := open("literat2.fil","w") + write("WRITING...") + while itm := get(fil) & itm ~== "" do { + writes(out_item,itm) + } + close(out_item) + write("DONE...") +end +# +# alpha: sorting in alphabetical order + procedure alpha() + + local fil, in_item, itm, out_item + + writes(char(27),"[2J") + write("READING...") + fil := list() + in_item := open("literat.fil","r") + while itm := reads(in_item,846) do { + put(fil,itm) + } + close(in_item) + write("ARRANGING DATA IN ALPHABETICAL ORDER...") + fil := sort(fil) + write("WRITING...") + out_item := open("literat2.fil","w") + while itm := get(fil) & itm ~== "" do { + writes(out_item,itm) + } + close(out_item) + write("DONE...") +end +# +# m_adress: function to generate a file with arguments to the seek() +# function. The file (adress.fil) will be used for sequential +# search in the computer's ram, (function (query()). The results enable +# the seek() function to place the internal file pointer on the desired +# item in literat.fil. + procedure m_adress() + + local a, adr, b, in_item, item, m, n, out_adr, out_line, wlist, wlist_2 + + out_line := "" + adr := edit_field(4,10,70,"FORMAT: <WORD>;<WORD>;ETC.","") + writes(char(27),"[2J") + write("GENERATING WORD LIST...") + wlist := list() + n := 1 + adr ? { + while put(wlist,tab(upto(";"))) do { + move(1) + write("ACTUAL WORD: ",wlist[n]) + n +:= 1 + } + } + in_item := open("literat.fil","r") + n := 1 + + wlist_2 := copy(wlist) +# Insert ; between word in wlist_2 and seqence of record numbers +# to be found out later. + while n <= *wlist_2 do { + wlist_2[n] ||:= ";" + n +:= 1 + } + n := 1 + while n <= *wlist do { + write("COMPARING WORD NUMBER: ",n,".") +# counter m: indicates record number + m := 1 + while item := reads(in_item,846) do { + if find(wlist[n],item) then { + wlist_2[n] ||:= m || ";" + } + m +:= 1 + } + wlist_2[n] ? { + a := tab(upto(";")) + b := tab(0) + } + if b == ";" then b := ";0" + wlist_2[n] := a || b + out_line ||:= wlist_2[n] || ":" +# When every item has been compared with wlist[n], move file +# pointer to the beginning of in_item and increase n by 1. + seek(in_item,1) + n +:= 1 + } + close(in_item) +# Remove trailing blank if any + if out_line[1] := " " then { + out_line := out_line[2:(*out_line+1)] + } + write("WRITING ADRESS FILE") + out_adr := open("adress.fil","a") + writes(out_adr,out_line) + close(out_adr) + write("OK") +end +# +# query(): find items using the numbers in adress.fil * 846 as +# arguments to the seek() function + procedure query() + + local byte, in_item, in_line, in_query, it_key, kkey, out_item, word, wrd + + writes(char(27),"[2J") + in_query := open("adress.fil","r") + in_line := read(in_query) + close(in_query) + in_item := open("literat.fil","r") + out_item := open("literat2.fil","a") + wrd := line(10,20,0,"TYPE WORD TO BE LOOKED FOR: ","") + word := wrd[1] + if byte := find(word,in_line) then { + in_line ? { + move(byte) + it_key := tab(upto(":")) + } + } + else { + locate(10,25) + writes("ERROR: UNKNOWN WORD! PRESS KEY!") + getch() + fail + } +# place internal cursor behind the first ; to get the first +# number: + it_key := it_key[find(";",it_key)+1:*it_key+1] + it_key ? { + while kkey := tab(upto(";")) do { + if kkey <= 0 then { + locate(10,25) + writes("ERROR: UNKNOWN WORD! PRESS KEY!") + getch() + fail + } + seek(in_item,(kkey-1)*846) + writes(out_item,edit_item(reads(in_item,846))) + move(1) + } + } + close(in_item) + close(out_item) + write("OK") +end +# +# main program. see the description of the program's functionS +# at the beginning of the source code and of every user-defined +# function if you are in doubt how to use them. +# + procedure main() + + local alist, blist, opt + + newkey() + alist := { + ["iNPUT","tURN OVER ITEMS","aDRESS FILE","qUERY","dEL","AlPHA","eND"] + } + blist := ["i","t","a","q","d","l","e"] + repeat { + repeat { + writes(char(27),"[2J") + locate(1,10) + write("LITERAT: EASY DATABASE SYSTEM") + locate(2,10) + write("WRITTEN BY: MATTHIAS HEESCH 1992") + if opt := menue("MENUE",alist,blist) then break + } + writes(char(27),"[2J") + case opt of { + "iNPUT" : in_itemm() + "tURN OVER ITEMS" : turn_over() + "aDRESS FILE" : m_adress() + "qUERY" : query() + "dEL" : del() + "AlPHA" : alpha() + "eND" : break + } + } +end |