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 / hebeng.icn < prev    next >
Text File  |  2001-05-02  |  10KB  |  298 lines
  1. ############################################################################
  2. #
  3. #    File:     hebeng.icn
  4. #
  5. #    Subject:  Program to print mixed Hebrew/English text
  6. #
  7. #    Author:   Alan D. Corre
  8. #
  9. #    Date:     May 2, 2001
  10. #
  11. ############################################################################
  12. #
  13. #   This file is in the public domain.
  14. #
  15. ############################################################################
  16. #
  17. #  This program is written in ProIcon for the Macintosh computer. Alan D. Corre
  18. #  August 1991. It takes input in a transcription of Hebrew which represents
  19. #  current pronunciation adequately but mimics the peculiarities of Hebrew
  20. #  spelling. Here are some sentences from the beginning of Agnon's story 
  21. #  "Friendship": marat qliyngel 'i$ah mefursemet haytah umenahelet beyt sefer
  22. #  haytah qowdem liymowt hamilHamah. mi$eni$tanu sidrey ha`owlam,neHtexah
  23. #  migdulatah..wexol miy $eyac'u low mowniyTiyn ba`owlam haytah mitqarevet
  24. #  'eclow weyowce't wenixneset leveytow" The letter sin is represented by the
  25. #  German ess-zed which is alt-s on the Mac and cannot be represented here.
  26. #  The tilde (~)toggles between English and Hebrew, so the word "bar" will be
  27. #  the English word "bar" or the Hebrew beyt-rey$ according to the current
  28. #  mode of the program. Finals are inserted automatically. Justification
  29. #  both ways occurs unless the program detects a blank or empty line, in
  30. #  which case the previous line is not justified.
  31. #  Since I took out non-ASCII chars, and have not rechecked that this
  32. #  works with the corresponding octal chars, there could be some slips in
  33. #  this text.
  34. #
  35. ############################################################################
  36. #
  37. #  Requires:  ProIcon
  38. #
  39. ############################################################################
  40.  
  41. $ifdef _MACINTOSH
  42.  
  43. global outfilename, outvar, outwin,hebrew_string_flag, hebrew_text_flag,
  44.     screenwidth,screenheight,markers
  45.  
  46. procedure main()
  47. #message() creates a standard Mac message box
  48.     if message("Do you wish to create a new text or print an old one?","New",
  49.         "Old") then newtext() else
  50.         oldtext()
  51. #Empty and hide the interactive window
  52.     wset(0,5)
  53.     wset(0,0)
  54. end
  55.  
  56.  
  57. procedure newtext()
  58.     set_markers()
  59.     get_info()
  60.     get_screensize()
  61.     create_file()
  62.     go()
  63. end
  64.  
  65. procedure oldtext()
  66. #getfile() allows selection of a file already available
  67.     outfilename := getfile("Please select file.",,)
  68. #attempt to open a window with the name of the file
  69.     if not (outwin := wopen(outfilename,"f")) then stop()
  70. #put a font in this window which has Hebrew letters in high ASCII numbers
  71.     wfont(outwin,"Ivrit")
  72. #use 12-point
  73.     wfontsize(outwin,12)
  74. #show the window. The user wishing to edit must make the window active
  75. #and use the appropriate alt keys to edit the Hebrew text. This is not
  76. #necessary when using the transcription initially
  77.     wset(outwin,1)
  78.     if message("Do you wish to edit? (Press return when through editing.)","Yes","No") then
  79.             read()
  80.     if message("Do you wish to print?","Yes","No") then
  81. #send the window to the printer if the user desires
  82.             wprint(outwin,1,1)
  83. end
  84.  
  85. procedure set_markers()
  86. #five letters preceding these characters take a special final shape
  87.     markers := ' ,.;:-\324\"?)]}'
  88. end
  89.  
  90.  
  91. procedure get_info()
  92. local dimlist
  93.     outfilename := gettext("What is the name of your output file?",,"Cancel")
  94.     if /outfilename then stop()
  95. #the program has to know what is the principal language in order to leave
  96. #blanks at paragraph endings properly. When the text flag is set, then the
  97. #program overall is operating in Hebrew mode. When the string flag is set
  98. #the current string is Hebrew
  99.     if message("What is the principal language of the text?","Hebrew","English") then
  100.         hebrew_string_flag := hebrew_text_flag := 1
  101.     if \hebrew_text_flag then {
  102.         if not message("The principal language used is Hebrew.","Okay","Cancel") then
  103.         stop()} else
  104.     if not message("The principal language used is English.","Okay","Cancel") then
  105.         stop()
  106. end
  107.  
  108. procedure get_screensize()
  109. local dimlist
  110. #&screen is a list. Work with the old standard mac screen
  111.     dimlist := &screen
  112.     screenheight := dimlist[3]
  113.     screenwidth := dimlist[4]
  114.     if screenwidth > 470 then screenwidth := 470
  115. end
  116.  
  117.  
  118. procedure create_file()
  119. #arrange the various fonts and sizes
  120.     outwin := wopen(outfilename,"n")
  121.     outvar := open(outfilename,"w")
  122.     wsize(0,screenwidth,(screenheight / 2 - 40))
  123.     wsize(outwin,screenwidth,(screenheight / 2 - 40))
  124.     wfont(outwin,"Ivrit")
  125.     wfontsize(outwin,12) 
  126.     wfont(0,"Geneva")
  127.     wfontsize(0,12)
  128. #position windows
  129.     wmove(0,0,40)
  130.     wmove(outwin,0,screenheight / 2 + 20)
  131.     wset(outwin,1) #show the output window
  132. end
  133.     
  134. procedure process(l)
  135. local cursor,substring,newline
  136. if *l = 0 then return " "
  137.     cursor := 1
  138.     newline := ""
  139. #look for a tilde, and piece together a new line accordingly
  140.     l ? while substring := tab(upto('~')) do {
  141.     move(1)
  142.     if \hebrew_string_flag then substring := hebraize(substring)
  143.     if /hebrew_text_flag then newline ||:= substring else
  144.         newline := (substring || newline)
  145. #string flag toggle
  146.     (/hebrew_string_flag := 1) | (hebrew_string_flag := &null)
  147.     cursor := &pos}
  148.     substring := l[cursor:0]
  149.     if \hebrew_string_flag then substring := hebraize(substring) 
  150.     if /hebrew_text_flag then newline ||:= substring else
  151.         newline := (substring || newline)
  152. return newline
  153. end
  154.  
  155. procedure justify(l)
  156. #doesn't give perfect right justification, but its good enough
  157. local stringlength,counter,n,increment,newline
  158.     stringlength := wtextwidth(outwin,l)
  159.     newline := l
  160.     increment := 1
  161.     while stringlength < screenwidth do {
  162.         counter := 0
  163.         l ? every n := upto(' ') do {
  164.                     newline[n + (counter * increment)] := "  "
  165.                     counter +:= 1
  166.                     stringlength +:= 4
  167.                     if stringlength >= screenwidth then break}
  168.         increment +:= 1}
  169. return newline
  170. end
  171.  
  172. procedure go()
  173. #the appearance of the Hebrew/English window lags one line behind the
  174. #input window
  175. local line,line2,counter,mess
  176.     counter := 0
  177.     line := read()    
  178. #octal 263 is option-period.
  179.     if line == "\263" then stop()
  180.     while (line2 := read()) ~== "\263" do {
  181.         counter +:= 1
  182.         if ((not match(" ",line2)) & (*line2 ~= 0)) then
  183.         line := justify(process(line)) else 
  184.           if /hebrew_text_flag then line := process(line) else
  185.                 line := rt(process(line))
  186.         if (wtextwidth(outwin,line) - screenwidth) > 10 then {
  187.             mess := "Warning. Line " || counter || " is " || (wtextwidth(outwin,line) -
  188.             screenwidth) || " pixels too long."
  189.             message(mess,"Okay","")}
  190.         write(outvar,line)
  191.         line := line2}
  192.     if /hebrew_text_flag then line := process(line) else
  193.         line := rt(process(line))
  194.             if (wtextwidth(outwin,line) - screenwidth) > 10 then {
  195.             mess := "Warning. Last Line is " || (wtextwidth(outwin,line) -
  196.             screenwidth) || " pixels too long."
  197.             message(mess,"Okay","")}
  198.     write(outvar,line)
  199.     if message("Do you wish to print?","Yes","No") then wprint(outwin,1,1)
  200.     close(outvar)
  201.     wclose(outwin,"")
  202. end
  203.  
  204. procedure hebraize(l)
  205. static s2,s3
  206. #' is used for aleph. For the abbreviation sign use either alt-] which gives
  207. #an appropriate sign, or alt-' which is easier to remember but gives a funny
  208. #looking digraph on the screen
  209.     initial{ s2 := "u\'\276\324bvgdhwzHTykKlmMnNs`pfFcCqr$\247tx\261\335(){}[]X"
  210.                      s3 := "\267\324\'\'\272\272\355\266\372\267\275\305\303\264\373\373\302\265_
  211.                                      \265\176\176\247\322\304\304\304\215\215\317\250\246\244\240_
  212.                                     \373+$)(}{][\373"}
  213. #the following (1) inserts initial aleph in case the student has forgotten it
  214. #(2) takes care of final x with vowel (all other finals are vowelless in
  215. #modern Hebrew (3) takes out vowels except u which is usually represented in
  216. #modern Hebrew (4) takes care of other finals (5) converts to Hebrew letters
  217. #(6) reverses to Hebrew direction
  218.     l := reverse(map(finals(devowel(xa(aleph(l)))),s2,s3))
  219. return l
  220. end
  221.  
  222. procedure aleph(l)
  223. #inserts an aleph in words beginning with vowels only
  224. #this alters the duplicate line; compare procedure devowel which rebuilds
  225. #the line from scratch
  226. local newl,offset
  227.     newl := l
  228.     offset := 0
  229.     if upto('aeiou',l[1]) then {
  230.         offset +:= 1
  231.         newl[1] := ("\'" || l[1])}
  232.         l ?  while tab(upto(' ')) do {
  233.                         tab(many(' '))
  234.                         if upto('aeiou',l[&pos]) then {
  235.                             newl[&pos + offset] := ("\'" || l[&pos])
  236.                             offset +:= 1}}
  237. return newl
  238. end
  239.  
  240. procedure xa(s)
  241. #takes care of the special case of final xa
  242. local substr,newstr
  243.     newstr := ""
  244.     s ||:= " "
  245.     s ? {while substr := tab(find("xa")) || move(2) || tab(any(markers)) do {
  246.                     substr[-3] := char(170)
  247.                     newstr ||:= substr}
  248.                 newstr ||:= s[&pos:-1]}
  249. return newstr
  250. end
  251.  
  252.  
  253. procedure finals(l)
  254. #arranges the final letters
  255. static finals,corresp
  256. local newline
  257. initial {finals := 'xmncf'
  258.                      corresp := table("")
  259.                      corresp["x"] := "\301"
  260.                      corresp["m"] := "\243"
  261.                      corresp["n"] := "\242"
  262.                      corresp["f"] := "\354"
  263.                      corresp["c"] := "\260"}
  264.     newline := l
  265.     l ? while tab(upto(finals)) do {
  266.                 move(1)
  267.                 if (any(markers)) | (&pos = *l + 1) then
  268.                     newline[&pos - 1] := corresp[l[&pos - 1]]
  269.                                                                     }
  270. return newline
  271. end
  272.  
  273. procedure rt(l)
  274. #for right justification; chars are of different size
  275. local stringlength,newline
  276.     stringlength := wtextwidth(outwin,l)
  277.     newline := l
  278.     if (screenwidth-stringlength) > 0 then
  279.     newline := (repl(" ",(screenwidth-stringlength +2) / 4) || l)
  280. return newline
  281. end
  282.  
  283. procedure devowel(l)
  284. local newline,substring
  285.     newline := ""
  286.     l ? {while substring := tab(upto('aeio')) do {
  287.         newline ||:= substring
  288.         move(1)}
  289.         newline ||:= l[&pos:0]}
  290. return newline
  291. end
  292.  
  293. $else   # not Macintosh
  294. procedure main()
  295.    stop("sorry, ", &progname, " only runs under Macintosh ProIcon")
  296. end
  297. $endif
  298.