╔══════════════════════════════════════════════╗ ║ DSKPAGE and PSKPAGE and PSPAGE and DSCROLL ║ ╚══════════════════════════════════════════════╝ Linux Version (rev. 11/29/09) Program to print, display or render into .ps format music from page specific intermediate files ─────────────────────────────────────────────────────── I. Program History The earliest examples of page specific i-files were generated in the process of typesetting Eleanor Field's Thematic Catalog of the Music of Benedetto and Alessandro Marcello. We needed to have the musical examples in a format that captured most of the intellegence involved in music typesetting, so that changes (improvements) to the output could be made with hand corrections to the "file" without having to add intellegence to the typesetting program. Once the i-file format became established, and a prototype of this program was written, it became possible to typeset and print scores and parts of music. The first major project was the production of a score and parts for Handel's oratorio Susanna, in 1989. At that time, the Center's programs were running on the old Ibycus system, and there was no provision in zbex for the graphical display of information on a screen. The first music printing program was called pskpage. It used bitmap fonts that were downloaded to an HP LaserJet and printed slurs using the graphics capabilities of HP's PCL3 printer language. In 1989, the Center began experimenting with a new system, running on an HPUX workstation. All data was transferred to this system in 1990, and the old Ibycus system was shut down and dismantled. A certain amount of data was lost in the transfer. In early 1991, WBH began work on a DOS based environment called TENW, which eventually grew to become the Center's operating environment. A new version of ibex, we all zbex, was designed and implemented, and TENW became TENX and then simply "the monster." By early 1992, zbex acquired the capability of displaying graphical images on the screen. Borrowing from the logic of the music printing program, the display program, called dskpage, displayed music on the screen using bitmap fonts and bitmap graphics. Very soon afterward, pskpage and dskpage were combined into one program using the conditional compile feature of zbex. The further history of the program is best captured in the revision documentation below. It is worth noting here that the program picked up two major capabilites recently. In November, 2008, the ability to output .ps postscript files was added (pspage), and in November, 2009, code was added to enable the display of a "scrolling" page of music (dscroll). II. Program Revisions PC Version 1.0 (rev. 5/14/93) PC Version 1.1 (rev. 11/11/93) PC Version 2.0 (rev. 01/01/95) This program will print or display pages of music from page files in score format. The program asks for the library and number of pages, then proceeds to print these one page at a time. Pages consist of one or more systems, each of which is handled independently by the print program. This means that systems can be moved from page to page with window editor Revision 11-11-93: Attribute records are ignored Revision 03-13-94: Size of superdata array increased to accommodate many notes under a beam. Former size of second dimension was 24. This meant that the maximum number of notes was 12. The third dimension is now set by the defined variable SUPERSIZE (set below). SUPERSIZE must be twice the number of notes to be accomodated. Also, it appears that certain array variables related to the production of beams must have one of their dimensions increased. The new dimension will be defined as BEAMNOTES. Revision 05-04-94: Printout portion of setbeam adjusted to accommodate unusually short stems. Revision 06-15-94: Program will recognize repeaters as legitimate beam components. The code for a repeater is "6" in beamcode. Repeaters are constructed from "hooks". There is a certain amount of vertical and horizontal shifting involved. I have not yet found a way to incorporate these "magic" numbers in hpar(.) and vpar(.). This problem must be solved at some point. Revision 09-13-94: The second numerical parameter of a text (T) record specifies the text line number, if it is 10 or less; otherwise, it specifies the vertical offset of the specific word of text. Revision 11-05-94: Provision made for displaying slurs longer than 800 dots. Revision 01-01-95: Program can be used to generate versions for different size notes. Revision 02-24-95: Continuation lines can be terminated by "~" text character. Revision 02-25-95: Program was initially set up to print a single line of text under music. To implement multiple lines (strophic), we need to have such variables as xbyte, dyoff, uxstart, and backloc be arrays since text lines are essentially independent. Revision 04-22-95: Program modified to print notesize = 21 music Revision 05-17-95: Program modified to print multiple note sizes Revision 05-29-95: Program unifed for all note sizes Revision 03-02-96: Adding capability to display (print) repeat beams Revision 10-10-96: Adding capability read n-digit (page) file names Revision 02-25-97: Program modified to ignore "silent" Sub-Objects Revision 03-01-97: Sharp, natural, or flat can be placed above trill super-object. Note: This is not a complete solution Revision 03-06-97: Implementing dotted slurs Revision 03/15/97: Implementing tuplets with numbers below and above bracket. Implementing curved (slur) tuplet brackets, with or without breaks for numbers. Note from the author, Walter B. Hewlett --------------------------------------- In the spring of 1997, I was elected to the Board of Overseers of Harvard College. My father suffered his second stroke in November of 1996, and managing his affairs required an increasing amount of my time over the next 4 years. In 1999, Agilent was spun off from Hewlett Packard. I remained on the Boards of both companies. In 1999, we also conducted a search for a new president of the Hewlett Foundation. The Flora Family Foundation was established about this time. My father died in January of 2001. I wrote some 300 personal letters in answer to letters we received from friends and admirers. In May of 2001, Carly Fiorina and the HP Board decided to explore a merger with Compaq Computer. The details were hammered out over the summer, and the merger was announced one week before 9/11/2001. In November of that year, the Hewlett Foundation decided to vote against the merger and I decided to mount an opposition campaign. The campaign was intense and lasted until March, 2002. We lost on a vote of 48.5% to 51.5%. After an unsuccessful Delaware court challange of the results, the merger was completed in May of 2002. At that time, I was voted off the HP Board. Revision 08/28/02: Added a second meaning to "X" records. With only two fields, this record changes the value of notesize (assuming the new value is legal). Revision 09/21/02: Trying to remove "magic numbers" from settie. There are four new horizontal parameters. These are put into hpar(60) to hpar(63). Revision 09/22/02: Adding provisions to increase number of note sizes. Size-18 being added. Increased size of parameter files for tie selection. (tpar files) Revision 04/20/03: Implementing post adjustment to tie position (fields 7, 8 and 9 of tie superobject) Revision 05/19/03: Adding new rules for the placement of secondary beams in the case of mixed stem directions on the grandstaff. Revision 05/26/03: Fixing problem with grandstaff repeat dots. They need to print on both staves: Case I: when the barline appears as an Object record, with repeat dot Subobjects, and Case II: when a forward repeat is thrown to the next system (i.e., Bar type: B 25). Revision 08/26/03: In an older version of this program hpar(15) was set at run-time to the position where text hyphons start on a new line. When multiple strophs were introduced, hpar(15) was discarded (not set), but remained in the code to set hyphons. New variable ibackloc(.) has be added to replace the old hpar(15). It is set to the values of backloc(.) as read in the Line record. Revision 08/28/03: There is a problem with multiple strophs on a line. Mskpage, as currently written, only sets one copy of the variables uxstart and backloc, even when there is more than one stroph. This is O.K., since uxstart and backloc are most likely going to be the same for all strophs. Dskpage must be alert to this fact, however, and must fill the uxstart backloc and ibackloc arrays appropriately when this situation occurs. Revision 08/28/03: Needed to fix the way an underline was terminated by ttext = "~" in the case where punctuation is present. Essentually, the "~" command functions in two parts: (1) It causes an underline to terminate before the note to which the "~" is attached, and (2) it extends the underline some distance beyond that note. Where punctuation is present, it must not be printed with operation (1), but rather with operation (2). Revision 08/31/03: In the case where a stroph phrase ends with an extension line and then is not continued, (e.g., when there is a repeat in middle of a line) we need a way to signal the end of the extension line; otherwise, it will continue to the end of the piece. If the stage2 file indicates an end to the extension line with the code "|&" (& representing the non-existant text), then this program will treat the "&" as = "no text" Revision 09/14/03: A 10th field has be added to Line (L) records. It is always set to zero by mskpage. This field provides an additional offset to the height of figured harmonies. It must be changed manually. Revision 10/01/03: Adding the condition on "W" type subobjects that if the font (variable z) is zero, no word (text) is printed. Print suggestions can then be used to blank out certain instructions in scores or parts. Revision 10/23/03: Modifying slightly the way in which dotted slurs are constructed Revision 11/06/03: Two modifications to how the vertical height of figure continuation lines is calculated. (1) If the height of figures is altered for an entire line by a non-zero figoff(.), then the height of figure continuation lines must also be altered by this amount. (2) It is possible to alter the height of figures manually, and we need this same ability for figure continuation lines. This requires the addition of an (optional) 7th Field in the Figure continuation superobject, which is defined to be the additional vertical displacement from the default height. Revision 11/11/03: DSKPAGE can now be used to view .MPG files (or any set of pages with a standard extension. The catch is that all files to be viewed must have the same extension. This could be fixed in the future. Also, a graceful exit was added for the case where no page numbers were found. Revision 11/13/03: Refining the way DSKPAGE reads and deals with control strings. This refinement is relevent in the case where there are mixed staff line sizes. Revision 11/18/03: Small trick to remove "holes" in size-21 staff lines (for display only). Staff lines will now remain visable at scale sizes 1/3 and 1/4. Revision 01/13/04: The mapping of font#1 (Ed's font) to the music font was not working properly for dskpage. This revision fixes the problem. Revision 01/17/04: We needed to add a terminator to the font designation field when it occurs in-line in text. The terminator is the "|" character, and needs to be removed at print/display time. Revision 03/05/04: DSKPAGE, on occasion, may be asked to display text. In some cases, the text may need to be right justified. The best way to do this is to provide for "in-line" space commands. Since the charaters 131 to 141 are currently unused (and un-printable) the idea is to implement the following (internal) representation: characters 131 to 139 = add 1 (to 9) dots of space character 140 = subtract one dot of space character 141 = subtract two dot of space It should be stressed that this representation is internal to DSKPAGE. The screen and printer never see these characters; nor do they ever appear in a file to be displayed or printed. The in-line commands that generate these characters are as follows: (these will appear in files to be displayed/printed) \! = add one dot of space \& = add seven dots of space \@ = add two dots of space \* = add eight dots of space \# = add three dots of space \( = add nine dots of space \$ = add four dots of space \- = subtract one dot of space \% = add five dots of space \= = subtract two dots of space \^ = add six dots of space Revision 03/15/04: Implementing a new system for organizing fonts. For the time being, we will keep the old system and old fonts around. Code for the new system will appear at #if NEWFONTS Revision 04/22/04: The new fonts include several new characters in the upper range (e.g. notes, accidentals, etc.). This necessitates the rewriting of certain sections of the text output. Also, the new word-join character contains its own pre-print backup command, removing the need to use hpar(4). Also, the way dskpage developed historically, there were two procedures that set text: setwords and settext. These have already been combined in the hardcoded DMUSE version, but need to be combined here as well. Revision 05/02/04: Adding the option to shift the contents of right and left side pages so as to center contents when pages are bound. We call this ODDEVENSHIFT, and it works only in PRINT mode. Revision 12/18/04: Adding notesize 18 Revision 01/03/05: Tightening up certain aspects of slur generation Revision 01/26/05: It turns out that dotted slurs were never implemented in the NOSTOCK (i.e., long slur) case. These additions correct this ommision. In addition, the thickness of notesize 6 longslurs was increased. Revision 02/12/05: Implementing "Y" type (tagged X) records. Also implementing "@" comment record. Revision 03/04/05: Implementing "C" and "R" type x-coordinates for X/Y records. Revision 03/04/05: Getting rid of all code alternate to NEWFONTS Revision 03/12/05: Adding new scaling "5" feature. Revision 03/26/05: No print option if font = 0 for "Y" type record Revision 04/26/05: No print option for a slur if bit-5 of sitf is set Revision 11/05/05: Adding new feature: It is now possible to print a trill accidental following the trill sign when combined with the super-object (R) ~~~~ Revision 11/11/05: Adding new feature: It is now possible to print a single line staff. This is signalled by an "l" in column-1 in place of "L" for the line record. Revision 02/19/06: Extending the music font set. The three dummies now contain twelve 48-glyph extensions to the twelve music fonts. The extended font numbers are 1001 to 1048 Adding two variables, both indexed by sizenum: dummy(12) = extended font number extendoff(12) = offset to first glyph in font, e.g., 32, 80, 160, 208 Revision 03/11/06: Fixing a bug in the way small brackets are printed Revision 11/30/07: New algorithm for avoid clash between tuple number and staff lines. There was a problem with the old algorithm when dealing with chords (double stops, etc.) Revision 04/22/08: Adding new feature: It is now possible to print a single tie character as a sub-object of a note. The character number is 2000 + the tie glyph number. This feature can be used to print back-ties at 2nd endings, etc. Revision 11/28/08: Adding the ability to produce a postscript file output. This new feature depends on the file j:/zprogs/apps/postdict being up-to-date. The program to do this is j:/zprogs/apps/mkpostf Revision 12/31/08: Implementing print/display of notesize 16 Revision 12/31/08: Fixing the backshift problem for cuesize hooks Revision 01/05/09: For our application, postscript files need to have a bounding box. If there is a caption at the bottom of the page, the box should not include this. If the page has a musical system, the left and right boundaries should be the staff line limits of the system. If the left system boundary is > 220 dots, the code should look for an instrument designation to the left of the system. This position will determine the left side of the bounding box. The units of the bounding box are converted from dots (1/300 inch) to postscript points (1/72 inch). The limits are communicated in a comment at the top of the postscript file. Revision 02/02/09: There needs to be a way of designating a "space" characters when printing text underlay (text with music). The sequence "\0+" already produces the "word-join" character. I propose using "\+" for an inline "space" character. Revision 03/08/09: Adding the ability to do "production level" postscript conversion. This involves a fair amount of new code, much of it derived from experimental programs in j:/release/progs/utils/e-coding. This also involves the modification of some dictionary entries derived from the file j:/zprogs/apps/postdict Revision 04/12/09: Fixing a bug in the PRINT version, re, placement of ending numbers. Revision 04/25/09: Adding the ability to force the display/print of an ending superobject which is below the top staff in a score. Revision 04/27/09: Addition to pspage. Craig wants a complete listing of the i-file that generates the .ps file to be appended at the bottom of the file. Revision 11/29/09: Adding dscroll. Andreas converts Leland's score files into a continuous "scrolling" format. He thinks it might be an advantage to get score files from the Center in this format. In order to make certain that the format is working in the i-file case, we needed a program to display this. Revision 01/31/10: Adding code that enables the display of tall brackets. This involved adding a glyph to the bracket fonts. Revision 04/28/10: New way to draw repeaters on notes connected to a beam #define PRINT 0 #define POSTSCRIPT 1 /* added 11/28/08 #define DSCROLL 0 /* added 11/29/09 #define ODDEVEN 0 #define ODDEVENSHIFT 1 /* added 05/02/04 #define SIZE18_SOLID 1 /* added 12/18/04 #define BRACKET_WARNING 0 /* added 12/11/05 #define BIG16 1 /* experimental only 01/02/09 #define LEFT_PAGE_SHIFT 89 #define RIGHT_PAGE_SHIFT 29 #define BEAM_OFFSET 12 #define TIE_OFFSET 25 #define LARGE_BRACK 42 #define SMALL_BRACK 43 #define HALF_10S 30 #define REPORT 0 #define SHOW_RECORDS 0 #define POST_REPORT 0 #define UP 0 #define DOWN 1 #define SUPERSIZE 64 #define SUPERMAX 50 #define MAX_BNOTES 32 #define LMRG1 8 #define LMRG2 4 #define LMRG3 3 #define LMRG4 2 #define LMRG5 6 /* LMRG5 added 12/18/04 #define TMRG1 146 #define TMRG2 73 #define TMRG3 49 #define TMRG4 37 #define TMRG5 100 /* TMRG5 added 12/18/04 #define N_SIZES 12 /* changed 03/15/04 from 4 to 12 #define TIE_DISTS 200 #define DOT_CHAR 44 #define MUSPRINT "c:/usr/local/apps/musprint" #define ZPROGS "c:/usr/local/apps/zprogs" str file.280,out.10000,line.480,line2.480,temp.480,tiefile.280(4) str outfile.280 str temp2.400 str sourcelib.200,tline.480 str textline.400,ttext.480 /* 03/04/05 textline len increased to 400 str jtype.1,htype.1,xbyte.1(10),cjtype.1,save_jtype.1 str beamcode.6(MAX_BNOTES),syscode.80 str name_ext.30 int tarr(32) int dyoff(10) int rec,saverec int beamh,beamt,beamfy,qwid,beamfont,stemchar,bthick int backloc(10),uxstart(10),uxstop(10) int ibackloc(10) /* New 08/26/03 OK int buxstop(10) int savenoby int underflag int pos(256),urpos(256),underspc(12),hyphspc(12) /* 03/15/04 spc(.) changed from 3 to 12 int wak(9),hpar(63),vpar(45),vpar20 int a,b,c,d,e,g,h,i,j,k,n,x,y,z int pz int q(12),beamext(435,12),tiearr(N_SIZES,4,TIE_DISTS,12) int sizenum int df int sk int @a,@b,@c,@d,@e,@k,@m,@q,@r int a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12 int c1,c2,c3,c4,c5,c6,c7,c8,c9 int f(32,10),f1,f2,f3,f4,f5,f11,f12,f13 int notesize,mtfont,supcnt,fsub,textlen int superdata(SUPERMAX,SUPERSIZE),supermap(SUPERMAX),superpnt(SUPERMAX) int tupldata(7),tbflag int sp,sq(32),sx,sy,vst(32) int x1,x2,y1,y2,z1,z2,z3 int bcount,beamdata(MAX_BNOTES,2) int d1,d2,d3 int ntype,stem int oby,sobx,soby,supernum int hd,vd,tiechar,sitflag,tcnt,textend,expar(8),tspan int sysy,sysh,syslen,sysflag,sysnum,sysright /* sysright added 12/31/08 int barbreak(10,2),brkcnt int obx,dv3,dv4 int lpt,addcurve int firstbarflag int music_con(255) int ntext,tlevel str esc.1,ff.1,quote.1 #if DSCROLL table X(500000) /* added 11/29/09 #else table X(100000) #endif int postx,posty int multiflag int naming_method int tpost_x,tpost_y,tpost_leng /* added 04/20/03 OK int figoff(32) /* added 09/14/03 OK int nsz(32) /* added 11/13/03 OK int govstaff /* added 11/13/03 OK int savensz /* added 11/13/03 OK int savesub /* added 11/13/03 int stave_type /* added 11/11/05 int hookbackshift(14) /* added 12/31/08 variables added to make screen display work 03/04/05 FA and gstr are now general variables needed for line length code int FA(750000) /* FA size inc. increased from .65m to .75m 07/15/04 str gstr.3000000 #if PRINT int pageside,xleftpageshift /* added 05/02/04 #else str tstr2.390000,tstr3.170000,tstr4.170000 /* gstr len incresased from 2.8m to 3.0m 07/15/04 str tstr5.1000000 /* New 03/12/05 + new blue strings for command 5 below str blue_horiz1t.400,blue_horiz2t.200,blue_horiz3t.150,blue_horiz4t.130,blue_horiz5t.300 str blue_horiz1b.400,blue_horiz2b.200,blue_horiz3b.150,blue_horiz4b.130,blue_horiz5b.300 str blue_vert1v.3500,blue_vert2v.1850,blue_vert3v.1300,blue_vert4v.1020,blue_vert5v.2400 str blue_vert1r.3500,blue_vert2r.1850,blue_vert3r.1300,blue_vert4r.1020,blue_vert5r.2400 str gline.360 str msgstr.7000 str curstr.200 int xco, yco int xze, yze str zline.480 int curdist int altflag int scx,scy,scb #endif int scf int revmap(400) variables added for printing long slurs and high slurs str longslur.320(250) int slur_edit_flag bstr bt.2500(250) bstr dotted.2500 int gapsize Variables added for dealing with NEWFONTS 03/15/04 str XFontstr.76(12) int nsizes(12),revsizes(24) int XFonts(12,19) int Fspacex(90) int wedgefont(24) int scfont(24) int Mbeamfont(24) Variables added for extended music fonts 02/19/06 int dummy(12) int extendoff(12) Variables added non-page specific output 11/29/09 #if DSCROLL int stationary int h_shift int e_recs(40) int line_cnt int end_cases int start_pnts(40,1000) /* These will be record numbers int start_pnts_cnt int start_trig int first_line_rec int rec_set_flag #endif table NC(100) /* number conversion table New 01/05/09 Variables added for producing postscript output 11/28/08 #if POSTSCRIPT int glyph_record(140,256) int moveto_count table SD(100000) /* slur dictionaries int sd_cnt table Y(5000) int ycnt table ST(50000) /* primary slur table int st_cnt table CT(10000) /* character table int ct_cnt table SST(10000) /* longslur table int sst_cnt table PD(20000) /* PostScript dictionary output int pd_cnt table PT(20000) /* PostScript character output int pt_cnt table PT2(1000) /* Auxiliary PostScript character output int pt_cnt2 table Z(2000) /* font/glyph usage table int zpnt,zpnt2 table XX(200000) /* "fontdict" table table CRG(20000) /* New 04/27/09 int crg_size /* New 04/27/09 int active_font str mtloc.100 str xystring_out.100 str xyshow_out.100 int lastx,lasty int top_limit /* New 01/05/09 int bottom_limit /* New 01/05/09 int left_limit /* New 01/05/09 int right_limit /* New 01/05/09 int sys_left_limit /* New 01/05/09 int sys_right_limit /* New 01/05/09 int edition_number /* New 03/08/09 str edition_date.100 /* New 03/08/09 int point(33,2) /* New 03/08/09 int matrix_offset(12,4) /* New 03/08/09 str grid.9(8) /* New 03/08/09 bstr bs1.32 /* New 03/08/09 str xhex.4(16) /* New 03/08/09 int pro_flag /* New 03/08/09 str post_cwd.300 /* New 03/08/09 #endif Explanation of Variables ──────────────────────────────── I. Horizontal distance related sp = x co-ordinate of line obx = object x co-ordinate sobx = sub-object x co-ordinte x = x co-ordinate for typesetting x1,x2 = firstbarflag = 0: first bar on a line; 1: subsequent bars on a line (print loop) postx = post adjustment to x co-ordinate after automatic computation of position II. Vertical distance related sq(32) = y co-ordinate of line (.) vst(32) = y displacement to virtual staff (if present, 0 otherwise) oby = object y co-ordinate soby = sub-object y co-ordinate y = y co-ordinate for typesetting y1,y2 = sy = post adjusted y for typesetting savenoby = save variable for oby dyoff(10) = y offset for directive thrown to next line posty = post adjustment to y co-ordinate after automatic computation of position figoff(32) = additional off-set for figured harmony nsz(32) = notesize for each staff line in a system New 11/13/03 OK govstaff = staff number whose notesize should be used New 11/13/03 OK for printing the left system bar, etc. savensz = temporary variable for saving notesize New 11/13/03 OK III. Record related rec = next record in file saverec = place to save current value of rec while browsing IV. Counting and space related tarr(32) = temporary array (1) = length of measure (2) = node number for terminating bar line (3) = type for terminating bar line IV. Type related jtype.1 = type of object cjtype.1 = type of object (control) htype.1 = type of super-object ntype = field three in an object record V. Super-object related supernum = super-object number supermap(50) = mapping pointer (SUPERMAX simultaneous super-objects) superpnt(50) = pointer into superdata storage array superdata(50,64) = information for compiling super-object SUPERMAX SUPERSIZE supcnt = number of super-objects attached to an object VI. Beam related beamdata(32,2) = data for typesetting beam MAX_BNOTES beamcode.6(32) = beamcode MAX_BNOTES bcount = number of notes under a beam beamfont = font for printing beam bthick = thickness of beamfont - 1 beamt = vertical space between beams beamh = height parameter for beams beamfy = y co-ordinate of first note under beam qwid = width of quarter note stem = stem direction flag stemchar = character number for stem tupldata(7) = data for typesetting tuplet at beam time tbflag = flag for setting tuplet with beam beamext(435,12) = parameters for beam extension hpar(59) = white space on either side of repeater beam hookbackshift(14) = backshift for printing a backward hook based on beamfont 12/31/08 VII. Tie related hd = horizontal displacement of tie from first note vd = vertical displacement of tie from first note tiechar = tie character tpost_x = post adjustment to left x position tpost_y = post adjustment to y position tpost_leng = post adjustment to right x position sitflag = situation flag for ties tcnt = counter for extending ties tspan = distance spanned by tie expar(8) = extension parameters for ties textend = tie extension character tiefile(4) = names of the four tie extension files tiearr(#,4,#,12) = parameters for choosing ties (New comment 12/18/04) hpar(60) = length beyond which ties for C5,D5 (tips up) and A4,G4 (tips down) are no longer constrained by staff lines hpar(61) = smallest distance between notes for which a tie may be printed hpar(62) = distance increment in tiearr data hpar(63) = last tie glyph number for a complete tie (longer ties are divided) VIII. Text related textline.232 = working string for text ttext.480 = text to typeset ntext = number of text lines for a particular music line tlevel = level number for line of text (field 3 of TEXT sub-object) xbyte.1(10) = extension byte (-_,.;:!?) (ten strophies) textlen = length of syllable to typeset backloc(10) = location of first space beyond last syllable ibackloc(10) = backloc(.) read from L record New 08/26/03 OK uxstart(10) = x-coord. of first space beyond last syllable uxstop(10) = x-coordinate of end of underline buxstop(10) = uxstop at bar line IX. Character related hyphspc(12) = space for text hyphon (notesizes: 6, 14, 16, 18, 21 --> 3, 8, 9, 10, 11) 12/31/08 underspc(12) = space for text underline character (notesizes: 6, 14, 16, 18, 21 --> 3, 8, 9, 10, 11) urpos(256) = vertical offsets for music font characters (basic units) pos(256) = vertical offsets for music font characters (notesize included) notesize = size of note mtfont = text font number z = number of character to typeset z1,z3,z3 = fsub = pointer into pos array X. Parameters hpar(63) = horizontal spacing parameters vpar(45) = vertical spacing parameters wak(9) = character extension values (upper range) XI. Flags f(32,*) = vertical position (offset) of line * of text f1 = page number f2 = number of pages f3 = page counter f4 = number of records in table f5 = f11 = number of parts f12 = current part number underflag = Explanation of Variables for NEWFONTS 03/15/04 ─────────────────────────────────────────── nsizes(12) = The 12 available note sizes sizes 3 [06], 8 [14], 10 [18], and 11 [21] are currently available revsizes(24) = The reverse map to nsizes XFonts(12,19) = The number of 10s and the 6 x 3 (sizes, styles) for each notesize XFontstr.76(12) = XFont data in string form Fspacex(90) = index from (TMS font number - 50) to record in fontspac(.) wedgefont(24) = font number for wedges for each notesize scfont(24) = fixed pitch font number for each notesize 03/15/04 Initializing arrays for NEWFONTS nsizes(1) = 4 nsizes(2) = 5 nsizes(3) = 6 nsizes(4) = 7 nsizes(5) = 8 nsizes(6) = 10 nsizes(7) = 12 nsizes(8) = 14 nsizes(9) = 16 nsizes(10) = 18 nsizes(11) = 21 nsizes(12) = 24 wedgefont(1) = 38 wedgefont(2) = 38 wedgefont(3) = 38 wedgefont(4) = 38 wedgefont(5) = 38 wedgefont(6) = 38 wedgefont(7) = 38 wedgefont(8) = 38 wedgefont(9) = 39 wedgefont(10) = 39 wedgefont(11) = 39 wedgefont(12) = 39 wedgefont(13) = 39 wedgefont(14) = 39 wedgefont(15) = 40 wedgefont(16) = 40 wedgefont(17) = 40 wedgefont(18) = 40 wedgefont(19) = 40 wedgefont(20) = 41 wedgefont(21) = 41 wedgefont(22) = 41 wedgefont(23) = 41 wedgefont(24) = 41 scfont(1) = 44 /* sc08 scfont(2) = 44 scfont(3) = 44 scfont(4) = 44 scfont(5) = 45 /* sc12 scfont(6) = 45 scfont(7) = 45 scfont(8) = 45 scfont(9) = 46 /* sc16 scfont(10) = 46 scfont(11) = 46 scfont(12) = 46 scfont(13) = 47 /* sc24 scfont(14) = 47 scfont(15) = 47 scfont(16) = 47 scfont(17) = 47 scfont(18) = 47 scfont(19) = 47 scfont(20) = 47 scfont(21) = 47 scfont(22) = 47 scfont(23) = 47 scfont(24) = 47 revsizes(1) = 1 revsizes(2) = 1 revsizes(3) = 1 revsizes(4) = 1 revsizes(5) = 2 revsizes(6) = 3 revsizes(7) = 4 revsizes(8) = 5 revsizes(9) = 6 revsizes(10) = 6 revsizes(11) = 7 revsizes(12) = 7 revsizes(13) = 8 revsizes(14) = 8 revsizes(15) = 9 revsizes(16) = 9 revsizes(17) = 10 revsizes(18) = 10 revsizes(19) = 10 revsizes(20) = 11 revsizes(21) = 11 revsizes(22) = 11 revsizes(23) = 12 revsizes(24) = 12 start with notesize, and a number 30 to 48 (19 possibilities) want a font number, that's all XFontstr(1) = " 51 51 81 111 51 81 111 52 82 112 53 83 113 54 84 114 56 86 116" XFontstr(2) = " 51 52 82 112 53 83 113 54 84 114 55 85 115 56 86 116 58 88 118" XFontstr(3) = " 51 54 84 114 55 85 115 56 86 116 57 87 117 58 88 118 60 90 120" XFontstr(4) = " 52 55 85 115 57 87 117 58 88 118 59 89 119 60 90 120 63 93 123" XFontstr(5) = " 53 57 87 117 58 88 118 59 89 119 61 91 121 62 92 122 64 94 124" XFontstr(6) = " 55 59 89 119 61 91 121 63 93 123 64 94 124 65 95 125 68 98 128" XFontstr(7) = " 57 62 92 122 64 94 124 65 95 125 67 97 127 69 99 129 72 102 132" XFontstr(8) = " 58 64 94 124 66 96 126 68 98 128 70 100 130 72 102 132 74 104 134" XFontstr(9) = " 60 67 97 127 69 99 129 71 101 131 73 103 133 74 104 134 76 106 136" XFontstr(10) = " 61 69 99 129 71 101 131 73 103 133 74 104 134 75 105 135 78 108 138" XFontstr(11) = " 64 72 102 132 74 104 134 75 105 135 77 107 137 78 108 138 79 109 139" XFontstr(12) = " 65 74 104 134 75 105 135 77 107 137 78 108 138 79 109 139 80 110 140" loop for i = 1 to 12 sub = 1 loop for j = 1 to 19 XFonts(i,j) = int(XFontstr(i){sub..}) repeat repeat loop for a1 = 1 to 30 Fspacex(a1) = (a1 - 1) * 10 + 1 Fspacex(a1+30) = Fspacex(a1) + 400 Fspacex(a1+60) = Fspacex(a1) + 800 repeat Mbeamfont(1) = 102 Mbeamfont(2) = 102 Mbeamfont(3) = 102 Mbeamfont(4) = 102 Mbeamfont(5) = 103 Mbeamfont(6) = 103 Mbeamfont(7) = 104 Mbeamfont(8) = 105 Mbeamfont(9) = 105 Mbeamfont(10) = 106 Mbeamfont(11) = 106 Mbeamfont(12) = 107 Mbeamfont(12) = 107 Mbeamfont(14) = 108 Mbeamfont(15) = 108 Mbeamfont(16) = 109 Mbeamfont(17) = 109 Mbeamfont(18) = 110 Mbeamfont(19) = 111 Mbeamfont(20) = 111 Mbeamfont(21) = 112 Mbeamfont(22) = 112 Mbeamfont(23) = 114 Mbeamfont(24) = 114 loop for a1 = 1 to 24 revmap(a1) = revsizes(a1) repeat loop for a1 = 1 to 12 revmap(100+a1) = a1 + BEAM_OFFSET repeat revmap(114) = 13 + BEAM_OFFSET End of 03/15/04 addition Special values for revmap(.) to deal with extended music fonts 02/19/06 These are necessary, because the putchar procedure always converts scf to a font number via revmap(.) We can't use the isomorphic map because revmap(48) is assigned to a character font number (14pt-italic). revmap(98) = 48 revmap(99) = 49 revmap(100) = 50 End of 02/19/06 addition 02/19/06 Initializing arrays for extended music fonts dummy(1) = 48 dummy(2) = 48 dummy(3) = 48 dummy(4) = 48 dummy(5) = 49 dummy(6) = 49 dummy(7) = 49 dummy(8) = 49 dummy(9) = 50 dummy(10) = 50 dummy(11) = 50 dummy(12) = 50 extendoff(1) = 32 extendoff(2) = 80 extendoff(3) = 160 extendoff(4) = 208 extendoff(5) = 32 extendoff(6) = 80 extendoff(7) = 160 extendoff(8) = 208 extendoff(9) = 32 extendoff(10) = 80 extendoff(11) = 160 extendoff(12) = 208 End of 02/19/06 addition 12/31/08 Initializing the hookbackshift array hookbackshift(1) = 7 hookbackshift(2) = 8 hookbackshift(3) = 8 /* for size 6 regular hookbackshift(4) = 11 hookbackshift(5) = 12 hookbackshift(6) = 14 hookbackshift(7) = 15 hookbackshift(8) = 17 /* for size 14 regular hookbackshift(9) = 18 hookbackshift(10) = 19 /* for size 18 regular hookbackshift(11) = 21 hookbackshift(12) = 22 /* for size 21 regular hookbackshift(13) = 24 hookbackshift(14) = 25 End of 12/31/08 addition Q1: 03/15/04 Since multiflag is now set to 1, all code where multiflag = 0 is being removed multiflag = 1 notesize = 14 03/15/04 Removing "x" as an "option," since this is now the only option putc Enter note size (<return> = 14) getc line line = trm(line) if line <> "" notesize = int(line) New 12/31/08 notesize 16 added to this code if chr(notesize) not_in [6,14,16,18,21] putc Note size of ~notesize is not supported at this time. putc Supported sizes are 6, 14, 16, 18 and 21 putc goto Q1 end end 03/15/04 Changing sizenum to range from 1 to 12 sizenum = revsizes(notesize) /* New 02/19/06 if notesize = 6 sizenum = 3 end if notesize = 14 sizenum = 8 end if notesize = 18 /* New 12/18/04 sizenum = 10 end if notesize = 21 sizenum = 11 end if notesize = 14 sizenum = 1 end if notesize = 21 sizenum = 2 end if notesize = 6 sizenum = 3 end mtfont = 31 Vertical Parameters ─────────────────── vpar(1) = one vertical note space vpar(2) = two " " spaces vpar(3) = three " " " vpar(4) = four " " " vpar(5) = five " " " vpar(6) = six " " " vpar(7) = seven " " " vpar(8) = eight " " " vpar(9) = nine " " " vpar(10) = ten " " " vpar(11) = vertical distance below staff line with text vpar(12) = vertical shift for printing two or more beams vpar(13) = vertical shift for printing ___ vpar(14) = vertical distance below staff line without text vpar(15) = vert. shift for printing italic 8 under treble clef vpar(16) = height parameter for beams vpar(17) = decrease in vpar(16) when range of notes exceeds vpar(3) vpar(18) = cutoff of wevere up-down pattern under beam vpar(19) = maximum rise in beam character vpar(20) = amount to add to beam height to get stradle vpar(21) = cutoff for shifting beams to middle of next line vpar(22) = fudge factor for two/more slanted beams on staff lines vpar(23) = fudge factor for one slanted beam on staff lines vpar(24) = maximum rise allowed for beam on one staff line vpar(25) = minimum rise allowed for beam crossing two staff lines vpar(26) = minimum rise allowed for beam crossing three staff lines vpar(27) = minimum for sum of two stems under 2-note beam vpar(28) = amount to extend stems in case vpar(27) is not reached vpar(29) = minimum stem length that triggers adding to 16th stem vpar(30) = adjustment for raising 16th beams because of short stems vpar(31) through vpar(34): beam spacing parameters ─────────────────────────────────────────────────── vpar(31) = beam thickness vpar(32) = offset between beams (if two or three) vpar(33) = offset between beams (if more than three in staff line) vpar(34) = amount by which a hanging beam exceeds line height Beam and line parameters ────────────────────────── Note Beam Beam large Hang Line size width offset offset delta width ────── ────── ────── ────── ────── ────── 12 7 10 11 1 1 14 8 11 12 1 1 16 9 13 14 1 1 18 10 14 16 1 1 20 11 16 17 1 1 22 12 18 19 2 2 24 13 19 21 2 2 26 14 21 23 2 2 28 15 22 24 2 2 30 16 24 26 3 2 vpar(35) = maximum beam slope for short beams vpar(36) = vertical location of level 1 of figures vpar(37) = height of figures vpar(38) = height of tuplet numbers vpar(39) = placement of tuplet numbers above notes or beams vpar(40) = bracket shift, when combined with tuplets vpar(41) = default offset increment (height) of text line vpar(42) = amount to shorten stems protruding into beams vpar(43) = size of vertical shift in display mode vpar(44) = width of staff line vpar(45) = placement of accidentals above trills (vpar(53) in AUTOSET) Horizontal Parameters ───────────────────── hpar(1) = length of standard beam character hpar(2) = length of beam hook character hpar(3) = width of quarter note (approximately) hpar(4) = back shift before concatination character 04/22/04 Not used any more hpar(5) = approximate width of grace note hpar(6) = hyphon spacing parameter (1/3 min distance for two hyp.) hpar(7) = overhang of underline past x-position of last note hpar(8) = left margin for staff lines 12/31/08 Not used any more hpar(9) = left margin + length of staff lines 12/31/08 Not used any more. replaced by sysright hpar(10) = increment after key signature for lines 2 ... hpar(11) = minimum space taken up by whole measure rest hpar(12) = amount by which a whole measure rest can be enlarged hpar(13) = distance between bar and multiple rest (run time set) hpar(14) = pseudo distance of continuation tie hpar(15) = (no longer used; replaced by ibackloc(.) ) New 08/26/03 OK hpar(16) = shift after bar line hpar(17) = minimum space for hyphon hpar(18) = minimum space for underline hpar(19) = skip before starting an underline hpar(20) = minimum space between underline and following syllable hpar(21) = indent margin for first line 12/31/08 Not used any more hpar(22) = not used hpar(23) = not used hpar(24) = not used hpar(25) = not used hpar(26) = not used hpar(27) = not used hpar(28) = not used hpar(29) = thickness of stem hpar(30) = backward shift for printing backward hook (for cross-piece repeaters only) hpar(31) = olddist adjustment following common/cut time on new line hpar(32) = shift following time number hpar(33) = thickness of heavy vertical line - thickness of light vertical line + 1 hpar(34) = heavy/light spacing + thickness of light line hpar(35) = shift back to print double dot repeat hpar(36) = shift forward to print double dot repeat hpar(37) = shift forward to print double bar at beginning of line hpar(38) = shift following double dot or double bar hpar(39) = minimum wedge length hpar(40) = length of trill extension character hpar(41) = advance after tr. character hpar(42) = width of 8av character hpar(43) = shift for printing dashes (font dependent) hpar(44) = length of figure line generation character hpar(45) = width of tuplet number hpar(46) = backshift for heavy vertical brace hpar(47) = backshift for bracket hpar(48) = space between double light bar lines + thickness of light line hpar(49) = shift for large number 12/31/08 Not used any more hpar(50) = half shift for large number 12/31/08 Not used any more hpar(51) = shift to middle of double digit time signature hpar(52) = shift to middle of single digit time signature hpar(53) = shift following common or cut time signature hpar(54) = shift after time signature hpar(55) = shift to commom time signature on new line hpar(56) = distance from end of continuation line to bar at end of line hpar(57) = same as above, but for case where line does not continue in next system hpar(58) = size of horizontal shift in display mode hpar(59) = white space on either side of a repeater beam hpar(60) = special case tie length for C5,D5 (tips up) and A4,G4 (tips down) hpar(61) = smallest distance between notes for which a tie may be printed hpar(62) = distance increment in tiearr data hpar(63) = last tie glyph number for a complete tie (longer ties are divided) Line and measure arrays ─────────────────────── Type # object ──────── ──────── 1 256th note 2 128th " 3 64th " 4 32nd " 5 16th " 6 eighth " 7 quarter " 8 half " 9 whole " 10 breve " 11 longa " 12 extended rest 13 whole measure rest 14 clef signature 15 key signature 16 time signature 17 other objects,directives 18 bar line 21-31 syncopated note 40 conflicting n-tuple Initialize Vertical and Horizontal Parameters expar(.) get shift parameters for music font file = MUSPRINT // "/new/mfonts/pos3" open [1,1] file loop for i = 1 to 223 getf [1] .t39 a urpos(i) = a repeat close [1] perform init_par Outputs: vpar(.) hpar(.) vpar20 expar(.) revmap(.) sizenum wak(1) = 140 wak(2) = 156 /* works for ç. but not for ø wak(3) = 131 wak(4) = 156 wak(5) = 128 wak(6) = 140 wak(7) = 128 wak(8) = 129 wak(9) = 130 quote = chr(34) esc = chr(27) ff = chr(12) ttext = "" loop for i = 1 to 255 music_con(i) = i repeat music_con(102) = 110 /* forte music_con(109) = 109 /* mezzo music_con(112) = 108 /* piano music_con(114) = 113 /* r music_con(115) = 111 /* s music_con(122) = 112 /* z #if PRINT putc #endif 03/04/05 Need screen fonts for line length code, even when PRINTING Get screen fonts file = ZPROGS // "/apps/newscrxx.fnt" open [1,5] file len(gstr) = sze read [1,1] gstr j = 1 loop for i = 1 to len(gstr) step 4 FA(j) = ors(gstr{i,4}) ++j repeat close [1] 12/01/08 Need postscript dictionary generator for POSTSCRIPT #if POSTSCRIPT file = ZPROGS // "/apps/postdict" open [5,1] file loop for i = 1 to 200000 getf [5] temp tput [XX,i] ~temp repeat eof5: close [5] 01/03/08 Also need to initialize the point(.,.) array for production level POSTSCRIPT conversion (data drawn from the getpat.z program) point(1,1) = 3 point(1,2) = 1 point(2,1) = 5 point(2,2) = 1 point(3,1) = 7 point(3,2) = 1 point(4,1) = 2 point(4,2) = 2 point(5,1) = 4 point(5,2) = 2 point(6,1) = 6 point(6,2) = 2 point(7,1) = 8 point(7,2) = 2 point(8,1) = 1 point(8,2) = 3 point(9,1) = 3 point(9,2) = 3 point(10,1) = 5 point(10,2) = 3 point(11,1) = 7 point(11,2) = 3 point(12,1) = 9 point(12,2) = 3 point(13,1) = 2 point(13,2) = 4 point(14,1) = 4 point(14,2) = 4 point(15,1) = 6 point(15,2) = 4 point(16,1) = 8 point(16,2) = 4 point(17,1) = 1 point(17,2) = 5 point(18,1) = 3 point(18,2) = 5 point(19,1) = 5 point(19,2) = 5 point(20,1) = 7 point(20,2) = 5 point(21,1) = 9 point(21,2) = 5 point(22,1) = 2 point(22,2) = 6 point(23,1) = 4 point(23,2) = 6 point(24,1) = 6 point(24,2) = 6 point(25,1) = 8 point(25,2) = 6 point(26,1) = 1 point(26,2) = 7 point(27,1) = 3 point(27,2) = 7 point(28,1) = 5 point(28,2) = 7 point(29,1) = 7 point(29,2) = 7 point(30,1) = 9 point(30,2) = 7 point(31,1) = 2 point(31,2) = 8 point(32,1) = 4 point(32,2) = 8 point(33,1) = 6 point(33,2) = 8 01/03/08 Also need to initialize the matrix_offset(.,.) array for production level POSTSCRIPT conversion (data drawn from the mat-locs file) matrix_offset(7,1) = 7 /* notesize 12 (tentative) matrix_offset(7,2) = 31 matrix_offset(7,3) = 1 matrix_offset(7,4) = 1 matrix_offset(8,1) = 9 /* notesize 14 matrix_offset(8,2) = 37 matrix_offset(8,3) = 1 matrix_offset(8,4) = 1 matrix_offset(9,1) = 10 /* notesize 16 matrix_offset(9,2) = 43 matrix_offset(9,3) = 3 matrix_offset(9,4) = 12 matrix_offset(10,1) = 13 /* notesize 18 matrix_offset(10,2) = 49 matrix_offset(10,3) = 4 matrix_offset(10,4) = 14 matrix_offset(11,1) = 16 /* notesize 21 matrix_offset(11,2) = 58 matrix_offset(11,3) = 5 matrix_offset(11,4) = 18 01/03/08 Also need to initialize the xhex(.) array for production level POSTSCRIPT conversion xhex(1) = " " xhex(2) = " x" xhex(3) = " x " xhex(4) = " xx" xhex(5) = " x " xhex(6) = " x x" xhex(7) = " xx " xhex(8) = " xxx" xhex(9) = "x " xhex(10) = "x x" xhex(11) = "x x " xhex(12) = "x xx" xhex(13) = "xx " xhex(14) = "xx x" xhex(15) = "xxx " xhex(16) = "xxxx" #endif get spacing parameters for hyphon and underline characters (text font) file = MUSPRINT // "/new/xfonts/tms/fontspac" loop for a1 = 1 to 12 open [1,1] file a2 = mtfont - 29 a3 = XFonts(a1,a2) - 50 a4 = Fspacex(a3) - 1 loop for j = 1 to a4 getf [1] repeat getf [1] line hyphspc(a1) = int(line{40,2}) getf [1] line getf [1] line getf [1] line underspc(a1) = int(line{10,2}) close [1] repeat get beam generation parameters file = MUSPRINT // "/new/beams/beamexs" open [1,1] file loop for i = 1 to 435 getf [1] q(1) q(2) q(3) q(4) q(5) q(6) q(7) q(8) q(9) q(10) q(11) q(12) loop for j = 1 to 12 beamext(i,j) = q(j) repeat repeat close [1] get tie placement parameters loop for a1 = 1 to 12 a2 = nsizes(a1) file = MUSPRINT // "/new/ties/tpar" if a2 < 10 file = file // "0" end file = file // chs(a2) if chr(a2) in [6,14,16,18,21] /* 12/30/08 size 16 included here else file = file // "x" end file = file // "/" tiefile(1) = file // "td-ns" tiefile(2) = file // "td-nl" tiefile(3) = file // "tu-ns" tiefile(4) = file // "tu-nl" loop for i = 1 to 4 open [1,1] tiefile(i) loop for j = 1 to 4 getf [1] repeat loop for j = 1 to ( TIE_DISTS ) getf [1] a q(1) q(2) q(3) q(4) q(5) q(6) q(7) q(8) q(9) q(10) q(11) q(12) loop for k = 1 to 12 tiearr(a1,i,j,k) = q(k) repeat repeat close [1] repeat repeat End of Initialization of parameters #if PRINT putc Print score page(s) from Intermediate files putc #else #if POSTSCRIPT putc Construct a postscript output from Intermediate files putc #else putc Display score page(s) from Intermediate files putc #endif #endif New 03/08/09: This code is part of the edition number implementation #if POSTSCRIPT putc Type <Enter> for production level postscript conversion; a non-blank putc line will result in an (in library) experimental conversion. getc line line = trm(line) pro_flag = 1 if line <> "" pro_flag = 0 goto LIBQ end putc In order for this postscript conversion to work properly, your cwd putc must be the edition library that contains the source data. An example putc would be: g:/beethoven/bhl/orch/sym7/editions/beta-2008. putc Furthermore, this library must contain a temporary output library putc called "postout.b46 tmp", and a small file called ednum, which contains putc an assigned edition number for this conversion and a date.b46 putc putc Please enter the library containing the .b46 mpg pages you wish to putc convert. Examples might be "score", or "parts/vln1". getc line2 line2 = trm(line2) getdir post_cwd sourcelib = post_cwd // "/" // line2 Getting the edition number and date string from "ednum" open [6,1] "ednum" getf [6] line line = line // " " if line con "Edition" or line con "edition" if line con " " line = line{mpt+1..} end edition_number = int(line) if edition_number < 1 or edition_number > 520000 putc Edition number ~edition_number is out of range. goto PDNOK end else putc Unable to find the edition number in ednum's first record goto PDNOK end getf [6] line line = line // " " if line con "Date" or line con "data" if line con " " line = line{mpt..} end line = mrt(line) if line = "" putc No date string is present in ednum's second record goto PDNOK end edition_date = line else putc Unable to find a date string in ednum's second record goto PDNOK end close [6] Using the edition number to get the code matrix open [7,5] "j:/dataout/editions/postscpt/admin/progs/codes" len(gstr) = sze read [7] gstr close [7] k = edition_number j = k * 4 + 1 i = ors(gstr{j,4}) loop for h = 1 to 8 grid(h) = "xxxxxxxxx" repeat line = ch4(i) bs1 = cbi(line) line = upk(bs1,"x.") /* e.g. x..x..x...x..x.x..x...x.x..x.x temp = rev(line) temp = temp{1,31} loop for j = 1 to 31 if temp{j} = "x" e = point(j,1) g = point(j,2) grid(g){e} = "." end repeat putc The matrix code for this edition number looks like this: putc loop for h = 1 to 8 putc ~grid(h) repeat putc goto PDOK eof6: close [6] putc Incomplete ednum file. It must have at least 2 records PDNOK: putc putc Program Halted putc stop #endif End of 03/08/09 Addition LIBQ: putc Source library? getc sourcelib sourcelib = trm(sourcelib) if sourcelib = "" goto LIBQ end if sourcelib con ":" or sourcelib{1} = "/" else getdir line sourcelib = line // "/" // sourcelib end PDOK: putc starting page number getc f1 putc number of pages getc f2 Code added 05/02/04 for oddeven shift #if PRINT pageside = 10 #if ODDEVENSHIFT putc Shift odd/even pages for better binding? Enter "Y" = yes getc line line = line // pad(1) if line = "Y" or line = "y" pageside = 0 xleftpageshift = 0 putc The even-page shift may cause words on the far left have a negative x position putc When this occurs, the printer places the words on the far right and the program putc issues a WARNING. This problem can be corrected by shifting the even-pages putc to the right by an amount that guarentees a positive x position for all words. putc Enter even-page shift in dots (300ths of a inch); Type <Enter> for none. getc xleftpageshift putc * end #endif #endif Determine page labeling method open [4,1] sourcelib LOOK_AGAIN: getf [4] temp if temp{1,5} = "<dir>" temp = temp{33..} putc directory -->~temp goto LOOK_AGAIN end temp = temp{33..} temp2 = temp name_ext = "" if temp con "." temp2 = temp // " " name_ext = temp2{mpt+1..} name_ext = trm(name_ext) temp2 = temp{1,mpt-1} end i = int(temp2) if i = 0 goto LOOK_AGAIN end goto LAG Graceful exit added 11/11/03 eof4: putc No page numbers found in the specified source library putc putc Program Halted putc stop LAG: naming_method = len(temp2) close [4] sourcelib = sourcelib // "/" Setup for printing and initialize strings for display #if PRINT putp .b27 *t300R ... #else #if POSTSCRIPT #else temp = chr(255) gline = dup(temp,360) setup blue_horiz1t,339,1,1 setup blue_horiz2t,178,1,1 setup blue_horiz3t,126,1,1 setup blue_horiz4t,100,1,1 setup blue_horiz5t,226,1,1 /* New 03/12/05 setup blue_horiz1b,339,1,1 setup blue_horiz2b,178,1,1 setup blue_horiz3b,126,1,1 setup blue_horiz4b,100,1,1 setup blue_horiz5b,226,1,1 /* New 03/12/05 setup blue_vert1v,1,3460,1 setup blue_vert2v,1,1810,1 setup blue_vert3v,1,1260,1 setup blue_vert4v,1,985,1 setup blue_vert5v,1,2304,1 /* New 03/12/05 setup blue_vert1r,1,3460,1 setup blue_vert2r,1,1810,1 setup blue_vert3r,1,1260,1 setup blue_vert4r,1,985,1 setup blue_vert5r,1,2304,1 /* New 03/12/05 blue_horiz1t{21,339} = gline{1,339} blue_horiz1b{21,339} = gline{1,339} blue_horiz2t{21,178} = gline{1,178} blue_horiz2b{21,178} = gline{1,178} blue_horiz3t{21,126} = gline{1,126} blue_horiz3b{21,126} = gline{1,126} blue_horiz4t{21,100} = gline{1,100} blue_horiz4b{21,100} = gline{1,100} blue_horiz5t{21,226} = gline{1,226} /* New 03/12/05 blue_horiz5b{21,226} = gline{1,226} /* New 03/12/05 temp = chr(4) blue_vert1v{21,3460} = dup(temp,3460) temp = chr(16) blue_vert1r{21,3460} = dup(temp,3460) temp = chr(8) blue_vert2v{21,1810} = dup(temp,1810) temp = chr(1) blue_vert2r{21,1810} = dup(temp,1810) temp = chr(128) blue_vert3v{21,1260} = dup(temp,1260) temp = chr(64) blue_vert3r{21,1260} = dup(temp,1260) temp = chr(64) blue_vert4v{21,985} = dup(temp,985) temp = chr(2) blue_vert4r{21,985} = dup(temp,985) temp = chr(64) /* New 03/12/05 blue_vert5v{21,2304} = dup(temp,2304) /* New 03/12/05 temp = chr(2) /* New 03/12/05 blue_vert5r{21,2304} = dup(temp,2304) /* New 03/12/05 #endif #endif #if DSCROLL h_shift = 0 /* added 11/29/09 #endif f3 = 0 BIG: f3 = f3 + 1 if f3 > f2 putc .b27 Y.b27 F... stop end file = "" if f1 < 10 and naming_method > 1 file = file // "0" end if f1 < 100 and naming_method > 2 file = file // "0" end if f1 < 1000 and naming_method > 3 file = file // "0" end file = file // chs(f1) #if POSTSCRIPT outfile = file // ".ps" This code added 03/08/09 for production postscript conversion if pro_flag = 1 outfile = post_cwd // "/postout.tmp/" // outfile else outfile = sourcelib // outfile end #endif if name_ext <> "" file = file // "." // name_ext end file = sourcelib // file Code added 05/02/04 for oddeven shift #if PRINT if pageside < 10 pageside = f1 & 0x01 end #endif Setup for display #if PRINT #else setup gstr,300,3100,3 #if POSTSCRIPT treset [SD] treset [Y] treset [ST] treset [CT] treset [SST] treset [PD] treset [PT] treset [PT2] treset [Z] sd_cnt = 0 ycnt = 0 st_cnt = 0 ct_cnt = 0 sst_cnt = 0 pd_cnt = 0 pt_cnt = 0 pt_cnt2 = 0 active_font = 0 #else setup tstr2,240,1600,1 setup tstr3,160,1040,1 setup tstr4,160,1040,1 setup tstr5,240,2100,1 /* New 03/12/05 bitmode 2, xze, yze xze >>= 3 #endif #endif Transfer source file to X table #if REPORT putc Transferring page ~f1 to memory ... #endif ++f1 #if ODDEVEN ++f1 #endif New code 01/05/09 to ascertain the left and right limits of a system #if POSTSCRIPT sys_right_limit = 0 sys_left_limit = 10000 a5 = 0 treset [CRG] /* New 04/27/09 #endif open [1,1] file treset [X] #if DSCROLL start_trig = 300 /* added 11/29/09 c2 = 0 /* added 11/29/09 first_line_rec = 0 /* added 11/29/09 start_pnts_cnt = 0 /* added 11/29/09 line_cnt = 0 /* added 11/29/09 loop for k = 1 to 500000 /* New 11/29/09 #else loop for k = 1 to 50000 #endif getf [1] line line = line // " " New code 01/05/09 to ascertain the left and right limits of a system #if POSTSCRIPT /* The line below is new 04/27/09 tput [CRG,k] ~line if line{1} = "S" tput [NC,1] ~line tget [NC,1] .t3 a1 a2 a3 a4 if a2 < sys_left_limit sys_left_limit = a2 end a4 += a2 if a4 > sys_right_limit sys_right_limit = a4 end a5 = 1 end if a5 = 1 if line{1,3} = "J D" if sys_left_limit > 220 tput [NC,1] ~line tget [NC,1] .t5 a1 a2 if a2 < 0 sys_left_limit += a2 end end a5 = 0 end end #endif tput [X,k] ~line New 11/29/09 This section added for dscroll to record various locations in the table X where reading should start and end. Purpose: faster response time #if DSCROLL if line{1} = "E" if start_pnts_cnt = 0 start_pnts_cnt = c2 end ++line_cnt e_recs(line_cnt) = k start_trig = 300 c2 = 0 end if line{1} = "J" tput [NC,1] ~line tget [NC,1] .t5 c1 c1 if c1 > start_trig ++c2 start_pnts(line_cnt+1,c2) = k /* This is a record number start_pnts(line_cnt+1,c2+1) = k start_pnts(line_cnt+1,c2+2) = k /* safety buffer start_trig += 500 end end if line{1} = "L" and first_line_rec = 0 first_line_rec = k end #endif End of 11/29/09 addition repeat eof1: close [1] #if REPORT putc Done! #endif #if POSTSCRIPT crg_size = k - 1 /* New 04/27/09 #endif f4 = k - 1 sysnum = 0 rec = 1 f12 = 0 #if DSCROLL end_cases = 0 /* added 11/29/09 line_cnt = 0 /* added 11/29/09 rec_set_flag = 0 /* added 11/29/09 #endif #if PRINT pz = revsizes(notesize) putp .b27 (~pz X... #endif scf = notesize TOP: New 11/29/09 This section added for dscroll to adjust the location in the table X where reading should start and end. Purpose: faster response time #if DSCROLL if end_cases > 100 or rec = e_recs(line_cnt+1) end_cases = 0 ++line_cnt rec = e_recs(line_cnt) rec_set_flag = 0 else if rec_set_flag = 0 if rec < e_recs(1) /* first line (line_cnt = 0) if rec > first_line_rec + 5 if h_shift > 0 c3 = h_shift / 500 if c3 > start_pnts_cnt c3 = start_pnts_cnt end rec = start_pnts(1,c3) rec_set_flag = 1 end end else if rec > e_recs(line_cnt) + 6 and rec < e_recs(line_cnt+1) if h_shift > 0 c3 = h_shift / 500 if c3 > start_pnts_cnt c3 = start_pnts_cnt end rec = start_pnts(line_cnt+1,c3) rec_set_flag = 1 end end end end end #endif End of 11/29/09 addition if rec > f4 #if PRINT putp ~ff ... #else #if POSTSCRIPT #if POST_REPORT putc Output from Character Table putc loop for i = 1 to ct_cnt tget [CT,i] out putc ~out repeat putc putc Compressing this output #endif xystring_out = "" ycnt = 0 pt_cnt = 0 loop for i = 1 to ct_cnt tget [CT,i] out Loop for special case of beginning of staff lines a1 = 0 a2 = len(out) if out{a2-2,3} = " 81" if active_font < 1013 /* music font a3 = len(xystring_out) if a3 > 0 if xystring_out{a3} <> "Q" a1 = 1 /* new staff lines end end end end if out con "charout" temp = out{25..} tput [Y,1] ~temp tget [Y,1] k k += 1000 if k <> active_font or len(xystring_out) > 60 or a1 = 1 if len(xystring_out) > 0 xystring_out = xystring_out // ")" putc ~xystring_out ++pt_cnt tput [PT,pt_cnt] ~xystring_out loop for j = 2 to ycnt - 1 tget [Y,j] temp putc ~temp ++pt_cnt tput [PT,pt_cnt] ~temp repeat tget [Y,ycnt] temp temp = temp // " 0 0 ] xyshow" putc ~temp ++pt_cnt tput [PT,pt_cnt] ~temp ycnt = 0 xystring_out = "" end if k <> active_font active_font = k putc /Bitfont~k findfont 24 scalefont setfont ++pt_cnt tput [PT,pt_cnt] /Bitfont~k findfont 24 scalefont setfont end if out con "loc =" h = mpt temp = out{h+7..} end tput [Y,1] ~temp tget [Y,1] h k lastx = h lasty = k perform move_to_loc (h,k) putc ~mtloc ++pt_cnt tput [PT,pt_cnt] ~mtloc if i = ct_cnt if out con "char =" h = mpt temp = out{h+7..} k = int(temp) temp = oct(k) putc (\~temp ) show ++pt_cnt tput [PT,pt_cnt] (\~temp ) show end goto CMP_DONE else tget [CT,i+1] temp if temp con "charout" temp = temp{25..} tput [Y,1] ~temp tget [Y,1] k k += 1000 if k <> active_font if out con "char =" h = mpt temp = out{h+7..} k = int(temp) temp = oct(k) putc (\~temp ) show ++pt_cnt tput [PT,pt_cnt] (\~temp ) show end goto NXT_CHAR end end end At this point, you have called for a new font and/or you are restarting the xystring_out and there is more than one character in this new font. Time to setup the xyshow macro. if out con "char =" h = mpt temp = out{h+7..} k = int(temp) if k > 31 and k < 127 and k <> 40 and k <> 41 and k <> 92 xystring_out = "(" // chr(k) else temp = oct(k) if len(temp) < 3 temp = "0" // oct(k) end xystring_out = "(\" // temp end ycnt = 2 temp = "[ " tput [Y,ycnt] ~temp end Otherwise, you are adding to the xyshow macro else if out con "loc =" h = mpt temp = out{h+7..} end tput [Y,1] ~temp tget [Y,1] h k perform compute_delta_move (lastx, lasty, h, k) lastx = h lasty = k if out con "char =" h = mpt temp = out{h+7..} k = int(temp) if k > 31 and k < 127 and k <> 40 and k <> 41 and k <> 92 xystring_out = xystring_out // chr(k) else temp = oct(k) if len(temp) < 3 temp = "0" // oct(k) end xystring_out = xystring_out // "\" // temp end end tget [Y,ycnt] temp temp = temp // " " // mtloc tput [Y,ycnt] ~temp if len(temp) > 60 ++ycnt temp = " " tput [Y,ycnt] ~temp end if i = ct_cnt if len(xystring_out) > 0 xystring_out = xystring_out // ")" putc ~xystring_out ++pt_cnt tput [PT,pt_cnt] ~xystring_out loop for j = 2 to ycnt - 1 tget [Y,j] temp putc ~temp ++pt_cnt tput [PT,pt_cnt] ~temp repeat tget [Y,ycnt] temp temp = temp // " 0 0 ] xyshow" putc ~temp ++pt_cnt tput [PT,pt_cnt] ~temp ycnt = 0 xystring_out = "" end end end end NXT_CHAR: repeat CMP_DONE: End of Postscript movement compression #if POST_REPORT putc Output from Slur Table putc #endif Build regular slur dictionaries pt_cnt2 = 0 n = 0 a1 = 0 a4 = 0 /* stores maximum height a5 = 0 /* stores maximum width loop for i = 1 to st_cnt tget [ST,i] out out = trm(out) if out con "Calling" a6 = 0 /* height counter ++n if n = 193 a1 = i - 1 /* last ":" in regular dictionary i = st_cnt /* exit loop end else if out{1} <> ":" ++a6 /* increment height a7 = len(out) if a7 > a5 a5 = a7 /* new maximum width end else if a6 = 0 /* this is the first ":" else if a6 > a4 a4 = a6 /* new maximum height end a6 = 0 /* redundant, but safe end end end #if POST_REPORT putc ~out #endif repeat if a1 = 0 a1 = st_cnt else n = 192 end The meaning of a1 is as follows: Normally (almost always) the number of regular slurs on a page will not exceed 192. In this case, a1 = st_cnt, and all regulars slurs will fit into one dictionary. When a1 < st_cnt, this means that there are regular slurs which did not fit into the primary slur dictionary and will need to be included in subsequent dictionaries. The meaning of n: n is the number of slurs in the primary slur dictionary putc putc Constructing the primary slur dictionaries a2 = 1 a3 = 1 if a1 > 0 perform build_regular_slur_dict (n, a2, a1, a4, a5, a3) end For the moment, this code assumes a maximum of two regular slur dictionaries, and will fail otherwise. if a1 < st_cnt n = 0 a2 = a1 + 1 /* next entry a1 = 0 a4 = 0 /* stores maximum height a5 = 0 /* stores maximum width loop for i = a2 to st_cnt tget [ST,i] out if out con "Calling" a6 = 0 /* height counter ++n if n = 193 putc For the moment, this code assumes a maximum of putc two regular slur dictionaries. No provision is putc made for overflow; extra slurs will be discarded. putc Type <return> if you wish to continue getc a1 = i - 1 /* last ":" in regular dictionary n = 192 i = st_cnt /* exit loop end else if out{1} <> ":" ++a6 /* increment height a7 = len(out) if a7 > a5 a5 = a7 /* new maximum width end else if a6 = 0 /* this is the first ":" else if a6 > a4 a4 = a6 /* new maximum height end a6 = 0 /* redundant, but safe end end end repeat if a1 = 0 a1 = st_cnt end a3 = 2 perform build_regular_slur_dict (n, a2, a1, a4, a5, a3) end Build long slur dictionaries #if POST_REPORT if sst_cnt > 0 putc Output from Longslur Table putc loop for i = 1 to sst_cnt tget [SST,i] out putc ~out repeat end putc Done #endif if sst_cnt > 0 a1 = 0 a2 = 0 a3 = 3 loop for i = 1 to sst_cnt tget [SST,i] out out = out // pad(4) if out{1,4} = "Call" a1 = i ++i /* skip ":" else if out{1} = ":" a2 = i perform build_long_slur_dict (a1, a2, a3) ++a3 end end repeat end putc Report of font and glyph usage putc zpnt = 0 loop for i = 1 to 140 k = 0 loop for j = 1 to 256 if glyph_record(i,j) > 0 if k = 0 putc font .w4 ~i putc ============== ++zpnt tput [Z,zpnt] font .w4 ~i ++zpnt tput [Z,zpnt] ============== k = 1 end putc .t4 char .w4 ~j .t40 ~glyph_record(i,j) occurances ++zpnt tput [Z,zpnt] .t4 char .w4 ~j end repeat repeat ++zpnt tput [Z,zpnt] $ perform build_page_pdict putc Total number of moveto's is ~moveto_count putc Done putc %!PS putc putc % This is the PD dictionary putc % ========================= loop for i = 1 to pd_cnt tget [PD,i] temp putc ~temp repeat putc % =========================== putc putc % This is the SD dictionary putc % ========================= loop for i = 1 to sd_cnt tget [SD,i] temp putc ~temp repeat putc % =========================== putc putc % This is the PT table putc % ==================== loop for i = 1 to pt_cnt tget [PT,i] temp putc ~temp repeat putc % =========================== putc putc % This is the PT2 table putc % ===================== loop for i = 1 to pt_cnt2 tget [PT2,i] temp putc ~temp repeat putc % =========================== putc putc showpage New code 01/05/09 to determine effective size of the display box. if sys_left_limit < 10000 left_limit = sys_left_limit right_limit = sys_right_limit else perform hpage_limits end perform vpage_limits putc Top limit = ~top_limit putc Bottom limit = ~bottom_limit putc Left limit = ~left_limit putc Right limit = ~right_limit Shift and transform coordinate system based on the notion that: The position of a dot in my system is actually the position of the lower-right corner of a dot. and that: (0,0) -> (12,756) which in dots is (50,3150) and that: the top/bottom system is reversed left_limit -= 1 top_limit -= 1 left_limit += 50 right_limit += 50 top_limit = 3150 - top_limit bottom_limit = 3150 - bottom_limit Convert dots to points, using 300 dpi Format = llx lly ulx uly temp = "" a1 = left_limit * 24 a2 = a1 / 100 a3 = rem temp = temp // chs(a2) // "." if a3 < 10 temp = temp // "0" end temp = temp // chs(a3) temp = temp // " " a1 = bottom_limit * 24 a2 = a1 / 100 a3 = rem temp = temp // chs(a2) // "." if a3 < 10 temp = temp // "0" end temp = temp // chs(a3) temp = temp // " " a1 = right_limit * 24 a2 = a1 / 100 a3 = rem temp = temp // chs(a2) // "." if a3 < 10 temp = temp // "0" end temp = temp // chs(a3) temp = temp // " " a1 = top_limit * 24 a2 = a1 / 100 a3 = rem temp = temp // chs(a2) // "." if a3 < 10 temp = temp // "0" end temp = temp // chs(a3) open [2,2] outfile putf [2] %!PS putf [2] %%BoundingBox: ~temp This code added 03/08/09 for production level postscript conversion if pro_flag = 1 putf [2] %% Edition Number = ~edition_number putf [2] %% Production Date = ~edition_date end putf [2] putf [2] % This is the PD dictionary putf [2] % ========================= loop for i = 1 to pd_cnt tget [PD,i] temp putf [2] ~temp repeat putf [2] % =========================== putf [2] putf [2] % This is the SD dictionary putf [2] % ========================= loop for i = 1 to sd_cnt tget [SD,i] temp putf [2] ~temp repeat putf [2] % =========================== putf [2] putf [2] % This is the PT table putf [2] % ==================== loop for i = 1 to pt_cnt tget [PT,i] temp putf [2] ~temp repeat putf [2] % =========================== putf [2] putf [2] % This is the PT2 table putf [2] % ===================== loop for i = 1 to pt_cnt2 tget [PT2,i] temp putf [2] ~temp repeat putf [2] % =========================== putf [2] putf [2] showpage New 04/27/09: Append Craig's Listing to ps file putf [2] putf [2] %*CraigBegin putf [2] %** CRAIG'S LISTING loop for k = 1 to crg_size tget [CRG,k] line line = trm(line) putf [2] %*~line repeat putf [2] %*CraigEnd close [2] goto BIG stop #else There are a lot of imbedded #if statements here. The code in the section below appies to NO_PRINT and NO_POSTSCRIPT. That is, it applies to display, both page-wise and dscroll. i = 0 #if DSCROLL #else activate gstr,0,0,-1 #endif perform pan (i) if i = 1 if f1 = 2 f1 = 1 f3 -= 1 else f1 -= 2 f3 -= 2 end else New 11/29/09 This section expanded for dscroll to deal with a new return from pan (i). If i = 3, this indicates a "scrolling" of the display page. #if DSCROLL if i = 2 --f1 --f3 else if i = 3 sysnum = 0 rec = 1 end_cases = 0 line_cnt = 0 f12 = 0 rec_set_flag = 0 scf = notesize setup gstr,300,3100,3 setup tstr2,240,1600,1 setup tstr3,160,1040,1 setup tstr4,160,1040,1 setup tstr5,240,2100,1 /* New 03/12/05 goto NO_BIG end end #else if i = 2 --f1 --f3 end #endif End of 11/29/09 addition end #endif #endif goto BIG /* This instruction is executed by all forms of the code end NO_BIG: tget [X,rec] line line = trm(line) #if SHOW_RECORDS putc .w6 ~rec ~line #endif ++rec if line{1} = "E" line = line // pad(12) loop for k = 1 to SUPERMAX if supermap(k) <> 0 #if DSCROLL supermap(k) = 0 superdata(k,3) = -10000 #else putc Outstanding superobject at end of line stop #endif end repeat loop for c8 = 1 to ntext if line{c8+2} <> " " if line{c8+2} <> "*" if line{c8+2} <> xbyte(c8) putc Current xbyte different from xbyte at end of line stop end y = sq(f12) + f(f12,c8) if xbyte(c8) = "-" x = sp + syslen perform sethyph (c8) end if "_,.;:!?" con xbyte(c8) uxstop(c8) = sp + syslen - hpar(56) underflag = 2 perform setunder (c8) end xbyte(c8) = "*" else if "_,.;:!?" con xbyte(c8) y = sq(f12) + f(f12,c8) underflag = 1 if uxstop(c8) > sp + syslen - hpar(57) uxstop(c8) = sp + syslen - hpar(57) end perform setunder (c8) end end end repeat goto TOP end if line{1} = "S" S Y S T E M (recoded 05/26/03) OK ─────────── f12 = 0 sysnum = sysnum + 1 #if REPORT putc System ~sysnum putc Line ... #endif sub = 5 sp = int(line{sub..}) Code added 05/02/04 for oddeven shift #if PRINT if pageside < 10 if pageside = 0 /* left side sp -= LEFT_PAGE_SHIFT sp += xleftpageshift else sp += RIGHT_PAGE_SHIFT end end #endif sysy = int(line{sub..}) syslen = int(line{sub..}) sysright = sysy + syslen /* added 12/31/08 sysh = int(line{sub..}) f11 = int(line{sub..}) line = line // " " tline = line{sub..} tline = mrt(tline) syscode = tline{2..} if syscode con quote syscode = syscode{1,mpt-1} end Code to check number of parts in syscode (modified 11/13/03) OK a2 = 0 loop for c8 = 1 to len(syscode) if ".:,;" con syscode{c8} ++a2 end repeat if a2 <> f11 and syscode <> "" putc Syscode Warning: Incorrect number of parts in syscode. rec = ~(rec - 1) end sysflag = 0 goto TOP end if line{1} = "L" if line{1} = "L" or line{1} = "l" /* New 11/11/05 L I N E ─────── New 11/11/05. Added feature: single line staff stave_type = 0 if line{1} = "l" line{1} = "L" stave_type = 1 end New 08/28/03. Must zero out parameters dyoff, uxstart, backloc, and ibackloc OK loop for c8 = 1 to 10 dyoff(c8) = 0 uxstart(c8) = 0 backloc(c8) = 0 ibackloc(c8) = 0 repeat line = line // " " f12 = f12 + 1 #if REPORT putc ~f12 ... #endif Field 2: y off-set in system sq(f12) = int(line{3..}) sq(f12) += sysy Field 3: text off-set(s) from line (separated by |) ntext = 0 NSR1: ++ntext f(f12,ntext) = int(line{sub..}) if line{sub} = "|" ++sub goto NSR1 end Field 4: dyoff(s) separated by | c8 = 0 NSR2: ++c8 dyoff(c8) = int(line{sub..}) if line{sub} = "|" ++sub goto NSR2 end Field 5: uxstart(s) separated by | c8 = 0 NSR3: ++c8 uxstart(c8) = int(line{sub..}) if line{sub} = "|" ++sub goto NSR3 end Field 6: backloc(s) separated by | c8 = 0 NSR4: ++c8 backloc(c8) = int(line{sub..}) ibackloc(c8) = backloc(c8) /* New 08/26/03 OK if line{sub} = "|" ++sub goto NSR4 end tline = line{sub+1..} tline = mrt(tline) Field 7: xbyte(s) (length of field = number of bytes) if tline con " " c8 = mpt - 1 if ntext < c8 loop for ntext = ntext + 1 to c8 f(f12,ntext) = f(f12,ntext-1) + vpar(41) repeat end loop for c8 = 1 to ntext xbyte(c8) = tline{c8} repeat end New 08/28/03 OK loop for c8 = 1 to ntext if dyoff(c8) = 0 dyoff(c8) = dyoff(1) end if uxstart(c8) = 0 uxstart(c8) = uxstart(1) end if backloc(c8) = 0 backloc(c8) = backloc(1) end if ibackloc(c8) = 0 ibackloc(c8) = ibackloc(1) end repeat Field 8: y off-set to virtual staff line (0 = none) vst(f12) = 0 if tline con " " tline = tline{mpt..} vst(f12) = int(tline) tline = tline // " " tline = tline{sub..} end Field 9: notesize (0 = not specified; i.e., no change) if tline con " " tline = tline{mpt..} c8 = int(tline) tline = tline // " " /* New code 09/14/03 OK tline = tline{sub..} /* " " " if chr(c8) in [6,14,16,18,21] /* New: notesize 16 added 12/31/08 not OK if c8 <> notesize notesize = c8 perform init_par end end end nsz(f12) = notesize /* New code 11/13/03 OK Field 10: additional off-set for figured harmony New 09/14/03 OK figoff(f12) = 0 if tline con " " tline = tline{mpt..} figoff(f12) = int(tline) tline = tline // " " /* New code 09/14/03 OK tline = tline{sub..} /* " " " end y = sq(f12) perform staff if vst(f12) > 0 y = sq(f12) + vst(f12) perform staff end loop for c8 = 1 to ntext buxstop(c8) = 1000000 repeat goto TOP end New Code 02/12/05 if line{1} = "@" @ - L I N E ─────────── goto TOP end if line{1} = "Y" Y - L I N E ─────────── sub = 3 z = int(line{sub..}) if z = 0 /* New 03/26/05 goto TOP end x = int(line{sub..}) 03/04/05 Deal with optional "C" or "R" following x-data ttext = " " if line{sub} = "C" or line{sub} = "R" ttext = line{sub} // " " ++sub end y = int(line{sub..}) tline = line{sub..} tline = mrt(tline) line = "X " // chs(z) // " " // chs(x) // ttext // chs(y) // " " /* New 03/04/05 line = "X " // chs(z) // " " // chs(x) // " " // chs(y) // " " if tline <> "" loop for i = 1 to len(tline) if tline{i} = "\" if i < len(tline) if ">]" con tline{i+1} ++i /* skip \> and \] else if "<[" con tline{i+1} loop while i < len(tline) and tline{i} <> "|" ++i /* skip up to "|" character repeat else line = line // tline{i} end end else line = line // tline{i} end else line = line // tline{i} end repeat end end End of 02/12/05 addition if line{1} = "X" X - L I N E ─────────── #if DSCROLL stationary = 1 /* added 11/29/09 #endif lpt = 3 tline = txt(line,[' '],lpt) z = int(tline) Code added 08/28/02 OK if lpt > len(line) if z = 6 or z = 14 or z = 21 or z = 18 or z = 16 /* New: notesize 16 added 12/31/08 not OK notesize = z perform init_par scf = notesize end goto TOP end tline = txt(line,[' '],lpt) tline = tline // " " /* New 03/04/05 x = int(tline) ttext = tline{sub} /* New 03/04/05 tline = txt(line,[' '],lpt) y = int(tline) if lpt > len(line) line = "" else line = line{lpt+1..} line = trm(line) end Code added 03/04/05 to deal with "C" and "R" options if ttext = "C" or ttext = "R" perform line_length (a1) if ttext = "C" a1 >>= 1 end x -= a1 end Code added 05/02/04 for oddeven shift (this code moved to here 03/04/05) #if PRINT if pageside < 10 if pageside = 0 /* left side x -= LEFT_PAGE_SHIFT x += xleftpageshift else x += RIGHT_PAGE_SHIFT end end #endif 04/22/04 Call to setwords now includes paramter: 0 = regular setwords call a1 = 0 perform setwords (a1) #if PRINT pz = revsizes(notesize) putp .b27 (~pz X... #endif scf = notesize goto TOP end if line{1} = "J" O B J E C T S ───────────── tget [X,rec-1] line .t3 jtype ntype obx oby z i i supcnt #if DSCROLL if obx > h_shift + 2200 /* added 11/29/09 ++end_cases goto TOP end #endif New code 09/14/03 OK if jtype = "F" oby += figoff(f12) end save_jtype = jtype if jtype = "N" savenoby = oby loop for c8 = 1 to ntext uxstop(c8) = sp + obx + hpar(7) buxstop(c8) = 1000000 repeat end * if jtype = "D" /* steve's version: if jtype in ['D','F'] if ntype = 0 goto CZ3 end if bit(1,ntype) = 1 goto CZ3 end if bit(2,ntype) = 1 and f12 = 1 goto CZ3 end if bit(3,ntype) = 1 and f12 = f11 goto CZ3 end /* skip over directives SKD2: tget [X,rec] line2 if line2{1} = "W" /* steve's version: if line2{1} in ['K','W'] ++rec goto SKD2 end goto TOP end Collect super-object information CZ3: if supcnt > 0 perform strip8 if int(line) <> supcnt /* TEMP putc strip error stop end lpt = 0 tline = txt(line,[' '],lpt) loop for i = 1 to supcnt tline = txt(line,[' '],lpt) j = int(tline) * look for previous reference to this superobject loop for k = 1 to SUPERMAX if supermap(k) = j goto WA end repeat h = 0 loop for k = 1 to SUPERMAX if supermap(k) = 0 h = k k = SUPERMAX end repeat if h = 0 putc No more superobject capacity stop end if not found, then set up reference to this superobject. k = h supermap(k) = j superpnt(k) = 1 * k (value 1 to SUPERMAX) = pointer into superdata for this superobject WA: h = superpnt(k) * store object information in superdata and increment superpnt superpnt(k) = h + 2 superdata(k,h) = obx superdata(k,h+1) = oby dputc Storing superdata putc .t10 superdata(~k ,~h ) = ~obx .t40 superdata(~k ,~(h+1) ) = ~oby repeat end if no sub-objects, then typeset object if vst(f12) > 0 and oby > 700 oby -= 1000 oby += vst(f12) end if z > 32 x = sp + obx if jtype <> "B" y = sq(f12) + oby perform setmus end end typeset underline (if unset) saverec = rec if jtype = "R" loop for c8 = 1 to ntext if "_,.;:!?" con xbyte(c8) check next note for new syllable YR4: tget [X,rec] line ++rec line = line // pad(12) if line{1} = "E" if line{c8+2} = "*" goto YR2 end goto YR3 end if line{1,3} = "J N" YR1: tget [X,rec] line ++rec if "kKA" con line{1} /* Added 11-11-93 goto YR1 end if line{1} = "T" c9 = int(line{3..}) c9 = int(line{sub..}) /* text line number if c8 = c9 goto YR2 end goto YR1 end goto YR3 end goto YR4 * YR2: y = sq(f12) + f(f12,c8) underflag = 1 if mpt > 1 uxstop(c8) -= hpar(20) end if buxstop(c8) < uxstop(c8) uxstop(c8) = buxstop(c8) end perform setunder (c8) xbyte(c8) = "*" buxstop(c8) = 1000000 end YR3: rec = saverec repeat end if jtype = "B" oby = 0 loop for c8 = 1 to ntext buxstop(c8) = sp + obx - hpar(57) repeat end goto TOP end if line{1} = "k" "Silent" S U B - O B J E C T S ────────────────────────────── goto TOP end if line{1} = "K" S U B - O B J E C T S ───────────────────── #if DSCROLL if obx > h_shift + 2200 /* added 11/29/09 ++end_cases goto TOP end #endif tget [X,rec-1] .t3 sobx soby z x = sp + obx + sobx y = sq(f12) + oby + soby perform setmus Adding code 05/26/03 for printing repeat dots on the grandstaff OK if save_jtype = "B" and z = DOT_CHAR y += vst(f12) perform setmus end goto TOP end if line{1} = "A" /* Added 11-11-93 A T T R I B U T E S ─────────────────── goto TOP end if line{1} = "W" or line{1} = "w" /* New 11/29/09 W O R D S ───────── #if DSCROLL if obx > h_shift + 2200 /* added 11/29/09 ++end_cases goto TOP end if line{1} = "W" stationary = 1 else stationary = 0 end #endif lpt = 3 tline = txt(line,[' '],lpt) * line structure = sobx soby font# text sobx = int(tline) tline = txt(line,[' '],lpt) soby = int(tline) tline = txt(line,[' '],lpt) z = int(tline) if len(line) > lpt and z <> 0 /* 10/01/03 adding condition z <> 0 OK line = line{lpt+1..} x = sp + obx + sobx y = sq(f12) + oby + soby a1 = 0 04/22/04 Call to setwords now includes paramter: 0 = regular setwords call perform setwords (a1) end goto TOP end if line{1} = "T" T E X T ─────── #if DSCROLL if obx > h_shift + 2200 /* added 11/29/09 ++end_cases goto TOP end stationary = 0 #endif line = line // " " * line structure = sobx tlevel[|soby] ttext xbyte textlen sobx = int(line{3..}) tlevel = int(line{sub..}) if tlevel < 1 or tlevel > 10 putc Error: Invalid tlevel in Text record ~(rec - 1) putc Enter blank line to stop program getc line line = trm(line) if line = "" stop end goto TOP end soby = 0 if line{sub} = "|" ++sub soby = int(line{sub..}) end line = line{sub..} line = mrt(line) /* ttext is next in line New 08/28/03 Stripping of ttext moved up 26 lines to here. We OK need to know if ttext = "~" in order to set underflag correctly. if line con " " ttext = line{1,mpt-1} line = line{mpt..} line = mrt(line) end typeset back hyphons or underlines (if they exist) if xbyte(tlevel) = "-" y = sq(f12) + f(f12,tlevel) x = sp + obx + sobx perform sethyph (tlevel) end if "_,.;:!?" con xbyte(tlevel) x = sp + obx + sobx - hpar(20) if mpt > 1 x -= hpar(20) end if uxstop(tlevel) > x uxstop(tlevel) = x end y = sq(f12) + f(f12,tlevel) if ttext = "~" underflag = 2 /* New 08/28/03 don't set punctuation 'till after next note. OK else underflag = 1 end underflag = 1 perform setunder (tlevel) end typeset underline if terminator (~) is found (Code added 02-24-95) if ttext = "~" x = sp + obx + sobx + hpar(20) + hpar(20) uxstop(tlevel) = x y = sq(f12) + f(f12,tlevel) underflag = 1 perform setunder (tlevel) xbyte(tlevel) = " " /* New 08/28/03 xbyte zeroed after calling setunder OK goto TOP end sub = 1 loop while ttext con "_" ttext{mpt} = " " repeat textlen = 0 xbyte(tlevel) = "*" if line <> "" line = line // " " xbyte(tlevel) = line{1} textlen = int(line{2..}) end x = sp + obx + sobx y = sq(f12) + f(f12,tlevel) + soby backloc(tlevel) = x + textlen uxstart(tlevel) = x + textlen + hpar(19) * print text 04/22/04 replacing settext with setwords Call to setwords now includes paramter: 1 = setwords called from TEXT sub-obj z = mtfont line = ttext a1 = 1 perform setwords (a1) perform settext goto TOP end if line{1} = "H" S U P E R - O B J E C T S ───────────────────────── #if DSCROLL if obx > h_shift + 2200 /* added 11/29/09 loop for k = 1 to SUPERMAX supermap(k) = 0 superdata(k,3) = -10000 repeat ++end_cases goto TOP end #endif lpt = 3 tline = txt(line,[' '],lpt) * line structure = supernum htype . . . supernum = int(tline) * get superdata for this superobject loop for k = 1 to SUPERMAX if supermap(k) = supernum goto WB end repeat #if DSCROLL goto TOP /* added 11/29/09 #else putc Error: No refererce to superobject ~supernum in previous objects examine stop #endif k = index into superdata. WB is the continuation point WB: #if DSCROLL if superdata(k,3) = -10000 /* added 11/29/09 supermap(k) = 0 goto TOP end #endif htype = txt(line,[' '],lpt) compensate for out-of-order objects if superdata(k,1) > superdata(k,3) x1 = superdata(k,3) y1 = superdata(k,4) superdata(k,3) = superdata(k,1) superdata(k,4) = superdata(k,2) superdata(k,1) = x1 superdata(k,2) = y1 end if htype = "T" structure of tie superobject: 4. vertical position of tied note 5. horiz. displacement from 1st note 6. horiz. displacement from 2nd note 7. post adjustment of calculated left x position 04/20/03 OK 8. post adjustment of calculated y position " 9. post adjustment of calculated right x position " 10. sitflag 11. recalc flag tline = txt(line,[' '],lpt) y1 = int(tline) tline = txt(line,[' '],lpt) x1 = int(tline) + superdata(k,1) tline = txt(line,[' '],lpt) x2 = int(tline) tline = txt(line,[' '],lpt) tpost_x = int(tline) /* added 04/20/03 etc. OK tline = txt(line,[' '],lpt) tpost_y = int(tline) tline = txt(line,[' '],lpt) tpost_leng = int(tline) tline = txt(line,[' '],lpt) sitflag = int(tline) tspan = superdata(k,3) + x2 - x1 perform settie supermap(k) = 0 #if DSCROLL superdata(k,3) = -10000 /* added 11/29/09 #endif goto TOP end if htype = "B" structure of beam superobject: slope vertoff font# #obs bc(1) ... tline = txt(line,[' '],lpt) @k = int(tline) tline = txt(line,[' '],lpt) @m = int(tline) tline = txt(line,[' '],lpt) beamfont = int(tline) i = Mbeamfont(notesize) /* covers all 12 notesizes if beamfont = i stemchar = 59 beamh = vpar(16) beamt = vpar(32) qwid = hpar(3) else stemchar = 187 beamh = vpar(16) * 4 / 5 beamt = vpar(32) * 4 + 3 / 5 qwid = hpar(5) end tline = txt(line,[' '],lpt) bcount = int(tline) New 11/29/09 This section add to prevent the construction of beams with incomplete data. #if DSCROLL j = superpnt(k) - 1 / 2 if j < bcount supermap(k) = 0 superdata(k,3) = -10000 goto TOP end #endif j = 1 loop for i = 1 to bcount beamdata(i,1) = superdata(k,j) + sp beamdata(i,2) = superdata(k,j+1) + sq(f12) temp = txt(line,[' '],lpt) temp = rev(temp) e = 6 - len(temp) beamcode(i) = temp // "00000"{1,e} j += 2 repeat * print beam tbflag = 0 if tupldata(1) > 0 and tupldata(5) = supernum tbflag = bit(4,tupldata(1)) ++tbflag end perform setbeam tupldata(1) = 0 supermap(k) = 0 #if DSCROLL superdata(k,3) = -10000 /* added 11/29/09 #endif goto TOP end if htype = "S" structure of slur superobject: 4. sitflag 5. extra horiz. displ. from obj-1 6. extra vert. displ. from obj-1 7. extra horiz. displ. from obj-2 8. extra vert. displ. from obj-2 9. extra curvature (new 6-30-93) 10. beam flag 11. post adjustment to x co-ordinate 12. post adjustment to y co-ordinate slur_edit_flag = 0 tline = txt(line,[' '],lpt) sitflag = int(tline) tline = txt(line,[' '],lpt) x1 = int(tline) + superdata(k,1) tline = txt(line,[' '],lpt) y1 = int(tline) if y1 <> 0 slur_edit_flag = 1 end y1 += superdata(k,2) tline = txt(line,[' '],lpt) x2 = int(tline) + superdata(k,3) tline = txt(line,[' '],lpt) y2 = int(tline) if y2 <> 0 slur_edit_flag = 1 end y2 += superdata(k,4) if y1 > 700 y1 -= 1000 y1 += vst(f12) end if y2 > 700 y2 -= 1000 y2 += vst(f12) end tline = txt(line,[' '],lpt) addcurve = int(tline) tline = txt(line,[' '],lpt) j = int(tline) postx = 0 posty = 0 if lpt < len(line) tline = txt(line,[' '],lpt) postx = int(tline) end if lpt < len(line) tline = txt(line,[' '],lpt) posty = int(tline) end if bit(5,sitflag) = 0 /* This condition added 04/26/05 perform putslur end supermap(k) = 0 #if DSCROLL superdata(k,3) = -10000 /* added 11/29/09 #endif goto TOP end if htype = "F" structure of figcon super-object: 4. figure level 5. horiz. disp. from obj1 6. horiz. disp. from obj2 7. (optional) additional vert. disp. New 11/06/03 from default height tline = txt(line,[' '],lpt) a3 = int(tline) tline = txt(line,[' '],lpt) x1 = int(tline) + superdata(k,1) tline = txt(line,[' '],lpt) x2 = int(tline) + superdata(k,3) Adding code 11/06/03 to look for optional additional vert. disp. y1 = 0 if lpt < len(line) tline = txt(line,[' '],lpt) y1 = int(tline) end perform putfigcon supermap(k) = 0 #if DSCROLL superdata(k,3) = -10000 /* added 11/29/09 #endif goto TOP end if htype = "X" structure of tuplet super-object: 4. situation flag 5. tuplet number 6. horiz. disp. from obj1 7. vert. disp. from obj1 8. horiz. disp. from obj2 9. vert. disp. from obj2 10. associated beam super-number tline = txt(line,[' '],lpt) sitflag = int(tline) tline = txt(line,[' '],lpt) a1 = int(tline) tline = txt(line,[' '],lpt) x1 = int(tline) tline = txt(line,[' '],lpt) y1 = int(tline) tline = txt(line,[' '],lpt) x2 = int(tline) tline = txt(line,[' '],lpt) y2 = int(tline) tline = txt(line,[' '],lpt) a2 = int(tline) if bit(3,sitflag) = 1 tupldata(1) = sitflag tupldata(2) = a1 tupldata(3) = x1 tupldata(4) = x2 tupldata(5) = a2 tupldata(6) = y1 tupldata(7) = y2 else x1 += superdata(k,1) y1 += superdata(k,2) x2 += superdata(k,3) y2 += superdata(k,4) if y1 > 700 y1 -= 1000 y1 += vst(f12) end if y2 > 700 y2 -= 1000 y2 += vst(f12) end perform puttuplet end supermap(k) = 0 #if DSCROLL superdata(k,3) = -10000 /* added 11/29/09 #endif goto TOP end For the rest of the superbjects, please see code at procedure save1 perform save1 supermap(k) = 0 #if DSCROLL superdata(k,3) = -10000 /* added 11/29/09 #endif goto TOP end if line{1} = "B" B A R L I N E (section recoded 05/26/03) OK ──────────────── sub = 3 a7 = int(line{sub..}) if a7 = 99 if sysflag = 0 #if REPORT putc #endif sysflag = 1 end goto TOP end First make sure that the system line is printed. (this code moved here and revised 11/13/03) OK savesub = sub savensz = notesize if sysflag = 0 #if REPORT putc #endif Code added here 11/13/03 to set govstaff for printing sysline, etc. OK govstaff = 0 a2 = 0 loop for c8 = 1 to len(syscode) if ".:,;" con syscode{c8} ++a2 if mpt > 2 if govstaff = 0 govstaff = a2 else if nsz(a2) > nsz(govstaff) govstaff = a2 end end end end repeat if govstaff = 0 govstaff = f11 /* default for govstaff end a2 = nsz(govstaff) if a2 <> notesize notesize = a2 perform init_par end perform sysline sysflag = 1 end sub = savesub a8 = a7 & 0x0f x = int(line{sub..}) brkcnt = int(line{sub..}) loop for i = 1 to brkcnt a6 = int(line{sub..}) barbreak(i,1) = a6 + sysy a6 = int(line{sub..}) barbreak(i,2) = a6 + sysy repeat * sort breaks in ascending order of offset if brkcnt > 1 c5 = brkcnt - 1 loop for c1 = 1 to c5 c6 = c1 + 1 loop for c2 = c6 to brkcnt if barbreak(c2,1) < barbreak(c1,1) c3 = barbreak(c1,1) c4 = barbreak(c1,2) barbreak(c1,1) = barbreak(c2,1) barbreak(c1,2) = barbreak(c2,2) barbreak(c2,1) = c3 barbreak(c2,2) = c4 end repeat repeat end * x = x + sp if a8 < 2 z = 82 perform barline end if a8 = 2 x = x - hpar(33) /* hpar(33) = heavy - light + 1 z = 84 perform barline end if a8 = 3 z = 86 perform barline end if a8 = 5 z = 82 perform barline x = x - hpar(48) /* hpar(48) = light + delta-light (auto hpar(44)) perform barline end if a8 = 6 z = 84 x = x - hpar(33) perform barline z = 82 x = x - hpar(34) /* hpar(34) = light + delta-heavy (auto hpar(45)) perform barline end if a8 = 9 z = 84 perform barline z = 82 x = x + hpar(33) + hpar(34) - 1 perform barline if a7 > 15 x = x + hpar(36) loop for f12 = 1 to f11 y = sq(f12) + vpar(3) z = 44 perform setmus y = y + vpar(2) perform setmus Adding code 05/26/03 for print second set of dots in case of grandstaff OK if vst(f12) > 0 y = y - vpar(2) + vst(f12) z = 44 perform setmus y = y + vpar(2) perform setmus end repeat end end if a8 = 10 z = 84 perform barline x = x - hpar(33) - hpar(34) + 1 perform barline end Code added 11/13/03 to reset notesize to local value OK if notesize <> savensz notesize = savensz perform init_par end goto TOP end goto TOP End of processing music data ╔═════════════════════════════════════════════════╗ ║ ║ ║ P R O C E D U R E S ║ ║ ║ ╚═════════════════════════════════════════════════╝ *P 1. setbeam Purpose: Typeset beams and accompanying notes and stems. Also typeset accompanying tuplet, if present Inputs: bcount = number of notes under beam beamdata(.,1) = x-position of note beamdata(.,2) = y-position of note beamcode(.) = beam code beam code = 6 digit number (string) 0 = no beam 1 = continue beam 2 = begin beam 3 = end beam 4 = forward hook 5 = backward hook 6 = single stem repeater 7 = begin repeated beam 8 = end repeated beam 100000's digit = eighth level beams 10000's digit = 16th level beams 1000's digit = 32nd level beams 100's digit = 64th level beams 10's digit = 128th level beams 1's digit = 256th level beams @k = distance from first object (oby of note group) to top of top beam (for stems up) or bottom of bottom beam (for stems down). @k > 0 means stem up. @m = number of dots the beam falls (rises = negative) in a distance of 30 horizontal dots. (i.e. slope * 30) beamfont = font for printing beam stemchar = character number for stem beamh = height parameter for beams beamt = vertical space between beams (normally vpar(32)) qwid = width of quarter note (normally hpar(3)) tupldata(1) = tuplet situation flag tupldata(2) = tuplet number tupldata(3) = x1 offset tupldata(4) = x2 offset tupldata(6) = y1 offset / For case where tuple goes over tupldata(7) = y2 offset \ note heads and there are chords. tbflag = print tuplet flag Outputs: prints out beams, stems and notes by means of procedures, printbeam, hook and revset. Internal variables: beamfy = y coordinate of first note under beam @b = y-intercept of beam @f = temporary variable @g = temporary variable (related to @@g) @h = temporary variable @i = temporary variable @j = temporary counter @k = |@m| @n = temporary variable @q = temporary counter @s = temporary variable @t = temporary variable @@b = vertical range of note set @@g = top of staff line @@n = temporary variable @@q = temporary variable bthick = thickness of beam - 1 (x1,y1) = temporary coordinates (x2,y2) = temporary coordinates z1,z2,z3 = temporary character numbers stemdir(80) = stem directions for mixed direction case stemends(80) = stem endpoints for mixed direction case beampos(8) = position of beam (mixed stem dir) beamlevel = index into beampos(one for each note belonging to beam) procedure setbeam int @b,@f,@g,@h,@i,@j,@n,@q,@s,@t int @@b,@@g,@@n,@@q int z2,mixflag int stemends(80),stemdir(80),beampos(8),beamlevel(MAX_BNOTES) int savex1 int staff_height int t1,t2,t3 /* NEW int bshflg calling information dputc Calling information loop for @b = 1 to bcount putc .t10 x = ~beamdata(@b,1) .t20 y = ~beamdata(@b,2) .t30 beamcode = ~beamcode(@b) repeat dputc check for errors in beam repeaters loop for @j = 1 to bcount if beamcode(@j) con "7" or beamcode(@j) con "8" if bcount <> 2 putc Improper use of beam repeaters goto BERR end loop for @j = 1 to 6 if "270" con beamcode(1){@j} if beamcode(1){@j} = "2" if beamcode(2){@j} <> "3" putc Mismatching beamcodes goto BERR end end if beamcode(1){@j} = "7" if beamcode(2){@j} <> "8" putc Mismatching beamcodes goto BERR end end if beamcode(1){@j} = "0" if beamcode(2){@j} <> "0" putc Mismatching beamcodes goto BERR end end else putc Improper use of beam repeaters goto BERR end repeat @j = 10000 end repeat Determine direction of first stem if @k = 0 or @k = 1 putc Old format for beams. This code has been disabled. putc Please run mskpage on data to get current format. putc putc Program Halted putc stop end if @k > 0 stem = UP else stem = DOWN end Check for situation where notes span two staves (grand staff) staff_height = 0 if vst(f12) > 0 @g = beamdata(1,2) loop for @j = 2 to bcount if abs(beamdata(@j,2) - @g) > 500 staff_height = 10000 @j = 10000 end repeat end Adjust all y coordinates be relative to the top staff loop for @j = 1 to bcount if beamdata(@j,2) - sq(f12) > 700 beamdata(@j,2) -= 1000 beamdata(@j,2) += vst(f12) if staff_height <> 10000 staff_height = vst(f12) end end repeat Check for mixed stem directions mixflag = 0 loop for @j = 2 to bcount @h = beamdata(@j,1) - beamdata(1,1) * @m / 30 @h = @h + beamdata(1,2) - @k - beamdata(@j,2) if @h < 0 if stem = DOWN mixflag = 1 @j = 10000 end else if stem = UP mixflag = 1 @j = 10000 end end repeat Deal with tuplets attached to note heads if tbflag = 1 @f = beamdata(bcount,1) - beamdata(1,1) @g = beamdata(bcount,2) - beamdata(1,2) * 30 @t = @g / @f @s = 0 @n = bcount - 1 loop for @i = 2 to @n @h = beamdata(@i,1) - beamdata(1,1) * @t / 30 + beamdata(1,2) @q = beamdata(@i,2) - @h if stem = DOWN @q = 0 - @q end if @q > @s @s = @q end repeat if stem = DOWN @j = vpar(39) + @s + sq(f12) y1 = beamdata(1,2) - @j y2 = beamdata(bcount,2) - @j else @j = vpar(39) + vpar(38) + @s - sq(f12) y1 = beamdata(1,2) + @j y2 = beamdata(bcount,2) + @j end Adding code 05/09/03 to make space for numbers inside brackets OK sitflag = tupldata(1) @s = vpar(1) if bit(0,sitflag) = 1 /* number present if bit(1,sitflag) = 1 /* bracket present if bit(4,sitflag) = 0 /* number near note head if bit(5,sitflag) = 1 /* continuous bracket if bit(6,sitflag) = 1 /* number inside if bit(2,sitflag) = 0 /* tips down y1 -= vpar(2) /* raise bracket y2 -= vpar(2) @s = vpar(3) else /* tips up y1 += vpar(2) /* lower bracket y2 += vpar(2) @s = vpar(2) end end end end end end if stem = DOWN if staff_height <> 10000 Code fix 11/30/07 trying a new algorithm for avoiding clash with staff lined @h = 0 - notesize * 2 / 3 + staff_height - @s if y1 > @h y1 = @h end if y2 > @h y2 = @h end @h = 0 - notesize * 2 / 3 + staff_height if (y1 + tupldata(6)) > @h y1 = @h - tupldata(6) end if (y2 + tupldata(6)) > @h y2 = @h - tupldata(6) end end else if staff_height <> 10000 Same code fix as above 11/30/07 @h = 11 * notesize / 2 + staff_height + @s if y1 < @h y1 = @h end if y2 < @h y2 = @h end @h = 11 * notesize / 2 + staff_height if (y1 + tupldata(6)) < @h y1 = @h - tupldata(6) end if (y2 + tupldata(6)) < @h y2 = @h - tupldata(6) end end end a1 = tupldata(2) x1 = tupldata(3) + beamdata(1,1) - sp x2 = tupldata(4) + beamdata(bcount,1) - sp y1 += tupldata(6) y2 += tupldata(7) perform puttuplet end bthick = beamfont - 101 beamfy = beamdata(1,2) Reverse all y co-ordinates if first stem is down @g = sq(f12) if stem = DOWN @g = vpar(2) * 500 - vpar(8) - @g loop for @j = 1 to bcount beamdata(@j,2) = vpar(2) * 500 - beamdata(@j,2) repeat end @@g = @g if stem = 1 @m = 0 - @m @k = 0 - @k end dv3 = @m * beamdata(1,1) dv3 = beamdata(1,2) - @k * hpar(1) - dv3 @k = abs(@m) @@q = 0 loop for @j = 1 to bcount @n = 5 if beamcode(@j) con "0" @n = mpt - 2 /* number of additional beams on this note end if @n > @@q @@q = @n /* max number of additional beams end repeat ++@@q if @@q > 3 beamt = vpar(33) end This is the printout portion of the procedure ───────────────────────────────────────────── @m = hpar(1) * slope of beam @k = |@m| dv3 = y-intercept of top of beam (times hpar(1)) identify beam characters z1 = @k + 33 if @m > 0 z1 += 128 end z2 = @k + 49 if @m > 0 z2 += 128 end check for tuplet over beam if tbflag = 2 sitflag = tupldata(1) if bit(7,sitflag) = 1 /* curved bracket 03/15/97 OK a4 = 0 - 2 * qwid / 3 if stem = UP a4 = qwid / 3 end else a4 = 0 - qwid / 3 if stem = UP a4 = 2 * qwid / 3 end end a1 = tupldata(2) x1 = beamdata(1,1) + a4 - sp + tupldata(3) x2 = beamdata(bcount,1) + a4 - sp + tupldata(4) y1 = @m * beamdata(1,1) + dv3 / hpar(1) y2 = @m * beamdata(bcount,1) + dv3 / hpar(1) if stem = DOWN y1 = vpar(2) * 500 - y1 - bthick - sq(f12) + vpar(39) + vpar(38) y2 = vpar(2) * 500 - y2 - bthick - sq(f12) + vpar(39) + vpar(38) else y1 = y1 - vpar(39) - sq(f12) y2 = y2 - vpar(39) - sq(f12) end y1 += tupldata(6) y2 += tupldata(7) perform puttuplet end Here the situation diverges Case I: all stems go in the same direction Case II: stem directions are mixed Case I: all stems go in the same direction if mixflag = 0 put in first beam x1 = beamdata(1,1) x2 = beamdata(bcount,1) if beamcode(1){1} = "7" x1 += hpar(59) x2 -= hpar(59) end perform printbeam put in vertical stems loop for @j = 1 to bcount x1 = beamdata(@j,1) y1 = @m * x1 + dv3 / hpar(1) + vpar(42) y1 += vpar(4) y2 = beamdata(@j,2) z3 = stemchar if y1 >= y2 z3 += 2 y1 -= vpar(2) loop while y1 < y2 perform revset y1 += vpar(2) repeat else loop while y1 < y2 perform revset y1 += vpar(4) repeat end y1 = y2 perform revset repeat put in other beams loop for @q = 2 to @@q if beamcode(1){@q} = "7" dv3 = (vpar(2) + beamt) * hpar(1) / 2 + dv3 else if beamcode(1){@q} = "6" dv3 = vpar(2) * hpar(1) + dv3 else dv3 = beamt * hpar(1) + dv3 end end bshflg = 0 loop for @j = 1 to bcount if "123456780" con beamcode(@j){@q} if mpt = 2 @i = @j BB1: ++@j if @j > bcount putc @j (~@j ) exceeds bcount (~bcount ) goto BERR end if "1234560" con beamcode(@j){@q} if mpt = 1 goto BB1 else if mpt = 3 * // print beam if @i > 1 and bshflg = 0 dv3 += (3 * hpar(1) / 8) bshflg = 1 end x1 = beamdata(@i,1) x2 = beamdata(@j,1) perform printbeam goto BBR * \\ else putc expecting a "1" or a "3" here (got a ~beamcode(@j){@q} ) putc beamcode(~@j ) = ~beamcode(@j) goto BERR end end end end if mpt = 7 * // print beam x1 = beamdata(1,1) + hpar(59) x2 = beamdata(2,1) - hpar(59) perform printbeam goto BBR * \\ end if mpt = 1 putc "1" not allowed in this position goto BERR end if mpt = 3 putc "3" not allowed in this position goto BERR end t1 = hpar(1) >> 1 if mpt = 4 * // print forward hook x1 = beamdata(@j,1) + hpar(29) y = @m * x1 + dv3 + t1 / hpar(1) z = z2 + 16 perform hook * \\ end if mpt = 5 * // print backward hook x1 = beamdata(@j,1) y = @m * x1 + dv3 + t1 / hpar(1) x1 -= hpar(30) x1 -= hookbackshift(beamfont-100) /* New 12/31/08 z = z2 perform hook * \\ end if mpt = 6 New 4/28/10: This code replaces older code x1 = beamdata(@j,1) t3 = int("0001122344567"{beamfont-100}) /* magic number t3 += 3 x1 -= t3 y1 = @m * x1 + dv3 + t1 / hpar(1) y = y1 z = z2 + 16 perform hook * // print forward and backward hooks to make cross piece x1 = beamdata(@j,1) y1 = @m * x1 + dv3 + t1 / hpar(1) x1 -= 5 y = y1 if @m > 0 y -= int("111111222222233"{@m}) end if @m < 0 y += int("111111222222233"{0-@m}) end z = z2 + 16 perform hook x1 -= hpar(30) - hpar(29) - 10 /* = 7 y = y1 if @m > 0 y += int("000111111222222"{@m}) end if @m < 0 y -= int("000111111222222"{0-@m}) end z = z2 perform hook * \\ end end BBR: repeat repeat else Case II: stem directions are mixed DEBUG dputc Calling information loop for @b = 1 to bcount putc .t10 x = ~beamdata(@b,1) .t20 y = ~beamdata(@b,2) .t30 beamcode = ~beamcode(@b) repeat dputc getc END DEBUG 1. Determine definitive stem directions and end points on main staff. loop for @j = 1 to bcount x1 = beamdata(@j,1) y1 = @m * x1 + dv3 / hpar(1) + 4 /* middle of main beam y2 = beamdata(@j,2) /* oby of note if y1 < y2 stemdir(@j) = UP else stemdir(@j) = DOWN /* different x intersection if stem = UP /* direction of first stem x1 -= qwid - hpar(29) else x1 += qwid - hpar(29) end y1 = @m * x1 + dv3 / hpar(1) + 4 end stemends(@j) = y1 repeat 2. Put in first beam x1 = beamdata(1,1) /* stemdir(1) is always UP x2 = beamdata(bcount,1) if stemdir(bcount) = DOWN if stem = UP x2 -= qwid - hpar(29) else x2 += qwid - hpar(29) end end perform printbeam beampos(1) = dv3 2a. Set beamlevel = 1 for all notes. beamlevel for notes will change as we move through the beam. Basically, if notes A and B start and end a beam respectively, then beamlevel will be given the same value for all of these notes and any that might be in between. If another beam extends between notes C and B, then beamlevel for these notes will be increased. In the end, beamlevel for each note will be the number of beams connecting or going through the stem for that note. loop for @j = 1 to bcount beamlevel(@j) = 1 repeat NEW 05/19/03 I am going to attempt a rewrite of this section. The problem OK with the old code was that it sometimes didn't give asthetically pleasing solutions. In particular, the problem arises when a secondary beam is to be drawn between endpoints whose stems are in different directions. The old code made the arbitrary decision to draw the secondary beam according to the direction of the stem of the initial note. This had the additional advantage that stems could be drawn as notes were processed, i.e., we would not have to go back and "lengthen" a stem because a secondary beam was drawn on the other side of the primary. With this rewrite, I must change this, i.e., stems cannot be drawn until all beams are set. Secondly, I need to come up with a set of rules as to how to deal with the situation where the endpoints of a secondary connect to stems of different directions. I propose to generate these rules from experience, and by trial and error. As we encounter situations where the result seems to violate common sense, then we can consider adding a new rule. It should be pointed out that at the moment there is no provision made for editing the decision made by this program as regards the placing of secondary beams. To add this feature, we would need to expand the contents of the beam super-object record. As of this date 05/19/03, I have only one rule to propose for cases where OK the endpoints have stems that go in different directions. 1. If there is a stem that follows the terminating stem, then use use this stem direction to "arbitrate" between the directions of the endpoint stems. If no stem follows, then the stem direction of the initial note wins. 3. Loop through notes, one at a time loop for @j = 1 to bcount x1 = beamdata(@j,1) if stemdir(@j) = DOWN if stem = UP x1 -= qwid - hpar(29) else x1 += qwid - hpar(29) end end savex1 = x1 a. add all extra beams starting at this note (and increase beamlevel accordingly) loop for @h = beamlevel(@j) + 1 to 6 if beamcode(@j){@h} = "2" /* begin beam ++beamlevel(@j) /* increment beamlevel for starting point loop for @g = @j + 1 to bcount if beamcode(@g){@h} = "3" /* end beam x1 = savex1 /* x1 needs to be reset for each beam x2 = beamdata(@g,1) /* if stemdir(bcount) = DOWN if stemdir(@g) = DOWN /* Correction 9-21-96 if stem = UP x2 -= qwid - hpar(29) else x2 += qwid - hpar(29) end end dv3 = beampos(1) Here is where the rules take effect. Case I: Use stem direction of first note to determine secondary beam position cases: 1) Normal: stemdir(@g) = stemdir(@j) 2) stemdir(@g) <> stemdir(@j) but either @g = bcount or stemdir(@g+1) = stemdir(@j) t2 = 0 if stemdir(@g) <> stemdir(@j) if @g < bcount if stemdir(@g+1) <> stemdir(@j) t2 = 1 end end end if t2 = 0 loop for @f = 1 to beamlevel(@g) if stemdir(@j) = UP if beampos(@f) > dv3 dv3 = beampos(@f) end else if beampos(@f) < dv3 dv3 = beampos(@f) end end repeat ++beamlevel(@g) /* increment beamlevel for endpoint if stemdir(@j) = UP dv3 += (beamt * hpar(1)) else dv3 -= (beamt * hpar(1)) end beampos(beamlevel(@g)) = dv3 perform printbeam b. adjust stem ends for notes under (over) this beam loop for @f = @j + 1 to @g if stemdir(@j) = UP if stemdir(@f) = DOWN stemends(@f) += beamt end else if stemdir(@f) = UP stemends(@f) -= beamt end end repeat else Case II: Use stem direction of last note to determine secondary beam position cases: 1) stemdir(@g) <> stemdir(@j), and @g < bcount, and stemdir(@g+1) = stemdir(@g) loop for @f = 1 to beamlevel(@g) if stemdir(@g) = UP /* changing @j to @g if beampos(@f) > dv3 dv3 = beampos(@f) end else if beampos(@f) < dv3 dv3 = beampos(@f) end end repeat ++beamlevel(@g) /* increment beamlevel for endpoint if stemdir(@g) = UP /* changing @j to @g dv3 += (beamt * hpar(1)) else dv3 -= (beamt * hpar(1)) end beampos(beamlevel(@g)) = dv3 perform printbeam b. adjust stem ends for notes under (over) this beam loop for @f = @j to @g if stemdir(@g) = UP /* changing @j to @g if stemdir(@f) = DOWN stemends(@f) += beamt end else if stemdir(@f) = UP stemends(@f) -= beamt end end repeat end @g = 10000 else Increment beamlevel for all notes between endpoints of this beam ++beamlevel(@g) end repeat if @g <> 10000 putc No termination found for beam goto BERR end else @h = 6 end repeat c. put in any hooks that might go with this note loop for @h = beamlevel(@j) + 1 to 6 if "456" con beamcode(@j){@h} /* begin beam @g = mpt loop for @f = 1 to beamlevel(@j) if stemdir(@j) = UP if beampos(@f) > dv3 dv3 = beampos(@f) end else if beampos(@f) < dv3 dv3 = beampos(@f) end end repeat if @g = 3 t1 = vpar(2) * hpar(1) else t1 = beamt * hpar(1) end if stemdir(@j) = UP dv3 += t1 else dv3 -= t1 end t1 = hpar(1) >> 1 if @g = 1 * // print forward hook x1 = savex1 + hpar(29) y = @m * x1 + dv3 + t1 / hpar(1) z = z2 + 16 perform hook end if @g = 2 * // print backward hook x1 = savex1 y = @m * x1 + dv3 + t1 / hpar(1) x1 -= hpar(30) x1 -= hookbackshift(beamfont-100) /* New 12/31/08 z = z2 perform hook end if @g = 3 * // print forward and backward hooks to make cross piece x1 = savex1 y1 = @m * x1 + dv3 + t1 / hpar(1) x1 -= 5 y = y1 if @m > 0 y -= int("111111222222233"{@m}) end if @m < 0 y += int("111111222222233"{0-@m}) end z = z2 + 16 perform hook x1 -= hpar(30) - hpar(29) - 10 /* = 7 y = y1 if @m > 0 y += int("000111111222222"{@m}) end if @m < 0 y -= int("000111111222222"{0-@m}) end z = z2 perform hook end else @h = 6 end repeat repeat 4. Loop again through notes, one at a time, and now draw the stems (05/19/03) OK loop for @j = 1 to bcount a. put in stem x1 = beamdata(@j,1) if stemdir(@j) = DOWN if stem = UP x1 -= qwid - hpar(29) else x1 += qwid - hpar(29) end end savex1 = x1 if stemdir(@j) = UP y1 = stemends(@j) y2 = beamdata(@j,2) else y2 = stemends(@j) y1 = beamdata(@j,2) + 2 /* I think this is needed end y1 += vpar(4) z3 = stemchar if y1 >= y2 z3 += 2 y1 -= vpar(2) loop while y1 < y2 perform revset y1 += vpar(2) repeat else loop while y1 < y2 perform revset y1 += vpar(4) repeat end y1 = y2 perform revset repeat End of 05/19/03 rewrite OK end return BERR: putc Beam format error, printbeam aborted return *P 2. hook Purpose: Typeset hook beam Inputs: @m = slope * hpar(1) x1 = horizontal position of note y = vertical position of hook attachment stem = stem direction z = hook character beamfont = type of font for beam procedure hook int pz /* added 03/15/04 x = x1 if stem = 1 y = vpar(2) * 500 - y - bthick z += 128 z &= 0xff else x += qwid - hpar(29) end #if PRINT pz = beamfont - 100 + BEAM_OFFSET putp .b27 (~pz X.b27 *p~x x~y Y.b(z) ... pz = revsizes(notesize) putp .b27 (~pz X... #else scf = beamfont scx = x scy = y scb = z perform charout #endif scf = notesize return *P 3. printbeam Purpose: Typeset beam Inputs: @m = slope * hpar(1) x1 = starting point of beam x2 = end point of beam dv3 = y intercept of beam (times hpar(1)) stem = stem direction z1 = beam character number for this slop procedure printbeam int pz /* added 03/15/04 int x3 x = x1 if stem = UP x += qwid - hpar(29) end #if PRINT pz = beamfont - 100 + BEAM_OFFSET putp .b27 (~pz X.b27 *p~x X... #else scx = x #endif scf = beamfont x2 = x2 + hpar(29) - hpar(1) y1 = @m * x1 + dv3 / hpar(1) if x2 < x1 and @k = 0 x2 = hpar(1) - hpar(2) + x2 /* no beam shorter than a "hook" y = y1 /* put out <n> "overlapping" hooks if stem = DOWN y = vpar(2) * 500 - y - bthick else x2 += qwid - hpar(29) end PBEAM01: #if PRINT putp .b27 *p~y Y.b65 ... #else scy = y scb = 65 perform charout #endif x += hpar(2) if x < x2 goto PBEAM01 end #if PRINT pz = revsizes(notesize) putp .b27 *p~x2 X.b65 .b27 (~pz X... #else scx = x2 scb = 65 perform charout #endif scf = notesize return end z = z1 if stem = DOWN z += 128 z &= 0xff end loop while x1 <= x2 y = y1 if stem = DOWN y = vpar(2) * 500 - y - bthick end #if PRINT putp .b27 *p~y Y.b(z) ... #else scy = y scb = z perform charout #endif x1 += hpar(1) y1 += @m repeat y2 = x2 + hpar(1) - x1 print fraction of beam y2 = extra length needed to complete beam if y2 = 0 #if PRINT pz = revsizes(notesize) putp .b27 (~pz X... #endif scf = notesize return end y = y1 if stem = DOWN y = vpar(2) * 500 - y - bthick end y = starting point if @k = 0 x = x1 - 30 + y2 if stem = UP x += qwid - hpar(29) end #if PRINT pz = revsizes(notesize) putp .b27 *p~x x~y Y.b33 .b27 (~pz X... #else scx = x scy = y scb = 33 perform charout #endif scf = notesize return end #if PRINT out = esc // "*p" // chs(y) // "Y" #else scy = y #endif x3 = @k - 1 * 29 + y2 if x3 < 1 or x3 > 435 /* added 11/29/09 return end x2 = beamext(x3,1) y1 = 2 loop for y2 = 1 to x2 z = beamext(x3,y1) if @m > 0 z += 128 z &= 0xff end if stem = 1 z += 128 z &= 0xff end #if PRINT out = out // chr(z) #else scb = z perform charout #endif if y2 < x2 ++y1 x1 = beamext(x3,y1) if stem = 1 x1 = 0 - x1 end if @m > 0 x1 = 0 - x1 end y -= x1 #if PRINT out = out // esc // "*p" // chs(y) // "Y" #else scy = y #endif ++y1 end repeat #if PRINT pz = revsizes(notesize) putp ~out .b27 (~pz X... #endif scf = notesize return *P 4. revset Purpose: Check for reversal of page and correct x y and z Inputs: x1 = horizontal position of note y1 = vertical position of note z3 = character to typeset stem = stem direction procedure revset x = x1 y = y1 z = z3 if stem = DOWN if z = 59 or z = 61 or z = 187 or z = 189 ++z end y = vpar(2) * 500 - y end perform setmus return *P 5. setmus Purpose: Typeset character Inputs: x = horizontal position of note y = vertical position of note z = character to typeset sizenum = current scale size (1 to 12) procedure setmus int sy,pz if z = 0 return end Implementing back ties as a character 04/22/08 if z > 1999 if z < 2032 return end if z > 2090 and z < 2160 return end if z > 2218 return end z -= 2000 /* z is now a legal single tie character scf = 300 #if PRINT pz = revsizes(notesize) + TIE_OFFSET /* tie font number putp .b27 *p~x x~y Y.b27 (~pz X.b(z) ... pz = revsizes(notesize) putp .b27 (~pz X... #else scx = x scy = y scb = z perform charout scf = notesize #endif return end Implementing extended music font 02/19/06 if z > 999 pz = dummy(sizenum) sy = y z = extendoff(sizenum) + z - 1001 #if PRINT putp .b27 *p~x x~sy Y.b27 (~pz X.b(z) ... pz = revsizes(notesize) putp .b27 (~pz X... #else scx = x scy = sy scb = z scf = pz + 50 /* scf is index into revmap producing fonts 48,49,50 perform charout scf = notesize #endif return end End of 02/19/06 addition sy = y - pos(z-32) #if PRINT putp .b27 *p~x x~sy Y.b(z) ... #else scx = x scy = sy scb = z perform charout #endif return 04/22/04 Setwords now occurs in one version: NEWFONTS *P 6. setwords (a1) Purpose: Typeset words Inputs: x = horizontal position of words y = vertical position of words z = font number for words line = words to set procedure setwords (a1) str textline.300 int pz /* added 03/15/04 int t1 04/22/04 Call to setwords now includes paramter: 0 = regular setwords call 1 = setwords called from TEXT sub-obj int a1 getvalue a1 04/22/04 This code taken from settext (08/31/03 OK) if a1 = 1 and line = "&" return end if x < 0 putc WARNING: Attempting to typeset a word with a (net) negative x position putc page = ~(f1 - 1) x = ~x end #if PRINT if z = 1 pz = revsizes(notesize) else if z <= 24 pz = revsizes(z) else t1 = revsizes(notesize) pz = XFonts(t1,z-29) end end putp .b27 *p~x x~y Y.b27 (~pz X... #else scx = x scy = y #endif if z = 1 /* added 03/15/04 scf = notesize else scf = z end textline = line // " " A11: if textline con "\" if mpt > 1 t1 = mpt line2 = textline{1,mpt-1} perform lineout textline = textline{t1..} goto A11 end if textline{2} = "\" line2 = "\" perform lineout textline = textline{3..} goto A11 end This coded added 03/05/04 to implement "in-line" space commands if "!@#$%^&*(-=" con textline{2} textline = chr(130+mpt) // textline{3..} goto A11 end This coded added 02/02/09 to implement in-line "space" character if textline{2} = "+" textline = " " // textline{3..} goto A11 end if textline{2} = "0" t1 = ors(textline{3}) + 128 if chr(t1) in [160,206,212,224] else line2 = chr(t1) perform lineout end textline = textline{4..} goto A11 end if textline{2} in ['a'..'z','A'..'Z'] d1 = ors(textline{2}) if textline{3} = "1" if "ANOano" con textline{2} t1 = d1 + 140 /* 140 = wak(1) else if textline{2} in ['A'..'Z'] t1 = 205 else t1 = 237 end end line2 = chr(t1) // textline{2} else if textline{3} = "5" if textline{2} in ['A'..'Z'] t1 = 211 /* 211 = wak(5)(=128) + 83(S) else t1 = 243 end line2 = chr(t1) // textline{2} else if textline{3} = "2" if "CcOos" con textline{2} if mpt < 3 line2 = chr(d1+156) // textline{2} /* 156 = wak(2) else if mpt < 5 line2 = chr(d1+143) // textline{2} /* 79(O) + 143 = 222 etc. else line2 = chr(244) /* German ss end end else line2 = textline{2} end else if textline{3} = "4" if "Aa" con textline{2} line2 = chr(d1+156) // textline{2} /* 156 = wak(4) else line2 = textline{2} end else if "7893" con textline{3} t1 = mpt + 127 /* wak(3,7,8,9) if ("73" con textline{3} and "Yy" con textline{2}) or "AEIOUaeiou" con textline{2} if textline{2} = "i" line2 = chr(d1+t1) // chr(238) /* 238 = dotless i else line2 = chr(d1+t1) // textline{2} end else line2 = textline{2} end else line2 = "\" perform lineout textline = textline{2..} goto A11 end end end end end perform lineout textline = textline{4..} goto A11 else line2 = "\" perform lineout textline = textline{2..} goto A11 end else t1 = len(textline) - 2 if t1 > 0 line2 = textline{1,t1} perform lineout end end #if PRINT pz = revsizes(notesize) putp .b27 (~pz X... #endif scf = notesize return End of setwords with NEWFONTS *P 6a. lineout Purpose: Send a line of text to output device Inputs: line2 z = font number for words Side effects: value of z may be changed value of scf may be changed procedure lineout int pz /* added 03/15/04 int t1, t2, t3 str textline.300 AAA111: if line2 con "!" t1 = mpt if t1 > 1 if z <> notesize and z <> 1 /* z <> 1 added 01/13/04 textline = line2{1,t1-1} else textline = "" loop for t2 = 1 to t1 - 1 t3 = ors(line2{t2}) t3 = music_con(t3) textline = textline // chr(t3) repeat end #if PRINT Code substitution 03/05/04: In order to implement "in-line" spacing for printing we have implemented a PRINT version of stringout. perform stringout (textline) putp ~textline ... #else perform stringout (textline) #endif line2 = line2{t1..} end if len(line2) > 1 if "0123456789" con line2{2} z = int(line2{2..}) #if PRINT if z = 1 pz = revsizes(notesize) else if z <= 24 pz = revsizes(z) else t1 = revsizes(notesize) pz = XFonts(t1,z-29) end end putp .b27 (~pz X... #endif if z = 1 /* added 03/15/04 scf = notesize else scf = z end if sub <= len(line2) line2 = line2{sub..} Code added 01/17/04 to remove terminator to font designation field if line2{1} = "|" if len(line2) = 1 return end line2 = line2{2..} end goto AAA111 else return end else if z <> notesize and z <> 1 /* z <> 1 added 01/13/04 textline = "!" else t3 = ors("!") t3 = music_con(t3) textline = chr(t3) end #if PRINT Code substitution 03/05/04: In order to implement "in-line" spacing for printing we have implemented a PRINT version of stringout. perform stringout (textline) putp ~textline ... #else perform stringout (textline) #endif line2 = line2{2..} goto AAA111 end end end if z <> notesize and z <> 1 /* z <> 1 added 01/13/04 OK textline = line2 else textline = "" loop for t2 = 1 to len(line2) t3 = ors(line2{t2}) t3 = music_con(t3) textline = textline // chr(t3) repeat end #if PRINT Code substitution 03/05/04: In order to implement "in-line" spacing for printing OK we have implemented a PRINT version of stringout. perform stringout (textline) putp ~textline ... #else perform stringout (textline) #endif return 03/04/05 New procedures added for determining the length (in dots) of a line of text. *P 7a. line_length Purpose: Determine the length (in dots) of a line of text before it is typeset. Inputs: line = line of text whose length is to be determined z = font active at time of call procedure line_length (xtot) str textline.400 str line2.400 int xtot,xinc int tscf int t1,t2,t3 xtot = 0 if z = 1 tscf = notesize else tscf = z end textline = line // " " LLL1: if textline con "!" t1 = mpt if t1 > 1 line2 = textline{1,t1-1} perform lineout_length (line2, tscf, xinc) xtot += xinc textline = textline{t1..} goto LLL1 end if "0123456789" con textline{2} t1 = int(textline{2..}) t2 = sub if textline{t2} = "|" ++t2 end if t1 = 1 tscf = notesize else tscf = t1 end textline = textline{t2..} goto LLL1 end t3 = 33 /* ! character perform get_xinc (tscf, t3, xinc) xtot += xinc textline = textline{2..} goto LLL1 end line2 = trm(textline) if line2 <> "" perform lineout_length (line2, tscf, xinc) xtot += xinc end passback xtot return *P 7b. lineout_length Purpose: Determine the length (in dots) of a line of text which has no font changes in it Inputs: line2 = line of text whose length is to be determined tscf = font active at time of call Output: xtot procedure lineout_length (line2, tscf, xtot) str line2.400,out.400 int tscf, xtot int xinc int t1,t2,t3 getvalue line2, tscf xtot = 0 line2 = line2 // " " LLL2: if line2 con "\" if mpt > 1 t1 = mpt out = line2{1,t1-1} perform string_length (out, tscf, xinc) xtot += xinc line2 = line2{t1..} goto LLL2 end if line2{2} = "\" t3 = 92 /* \ character perform get_xinc (tscf, t3, xinc) xtot += xinc line2 = line2{3..} goto LLL2 end if "!@#$%^&*(-=" con line2{2} t1 = mpt if t1 < 10 xtot += t1 else xtot -= (t1 - 9) end line2 = line2{3..} goto LLL2 end if line2{2} = "0" t3 = ors(line2{3}) + 128 if chr(t3) in [160,206,212,224] else perform get_xinc (tscf, t3, xinc) xtot += xinc end line2 = line2{4..} goto LLL2 end if line2{2} in ['a'..'z','A'..'Z'] t3 = ors(line2{2}) if line2{2,2} = "s2" t3 = 244 /* German ss perform get_xinc (tscf, t3, xinc) xtot += xinc line2 = line2{4..} goto LLL2 else if "12345789" con line2{3} if ("73" con line2{3} and "Yy" con line2{2}) or "AEIOUaeiou" con line2{2} perform get_xinc (tscf, t3, xinc) xtot += xinc line2 = line2{4..} goto LLL2 end end end end t3 = 92 /* \ character perform get_xinc (tscf, t3, xinc) xtot += xinc line2 = line2{2..} goto LLL2 end out = trm(line2) if out <> "" perform string_length (out, tscf, xinc) xtot += xinc end passback xtot return *P 7c. string_length Purpose: Determine the length (in dots) of a line of text which has no font changes and no "\" character Inputs: out = line of text whose length is to be determined tscf = font active at time of call Output: xtot procedure string_length (out, tscf, xtot) str out.500 int k,xinc,xtot,tscf getvalue out, tscf xtot = 0 loop for i = 1 to len(out) k = ors(out{i}) if tscf = notesize k = music_con(k) end perform get_xinc (tscf, k, xinc) xtot += xinc repeat passback xtot return *P 7d. get_xinc Purpose: Determine the x increment to printing a glyph from a particular font. Inputs: z = font active k = glyph number Output: xinc = increment procedure get_xinc (z,k,xinc) int z,k,xinc int font int t1,t2 getvalue z,k font = revmap(z) font = font - 1 * 256 k += font t1 = FA(k) /* offset in FA of this glyph t2 = FA(t1+1) /* second integer of header data t2 >>= 24 /* value of xinc for this glyph xinc = t2 & 0xff passback xinc return End of 03/04/05 Addition *P 8. staff Purpose: Typeset staff Inputs: y = absolute vertical location sp = starting point of staff lines syslen = length of staff lines stave_type = type of staff 0 = 5-line 1 = single line procedure staff int slen if notesize >= 10 slen = 64 else slen = 32 end New 11/11/05: Single line stave if stave_type = 1 y += vpar(4) d2 = sp + syslen - hpar(1) z = 90 loop for x = sp to d2 step hpar(1) perform setmus repeat x = d2 perform setmus y -= vpar(4) return end End of 11/11/05 addition #if PRINT d2 = sp + syslen - slen z = 81 loop for x = sp to d2 step slen perform setmus The size-18 staff line may be printed either in its "THIN" version or in a doubled-up "SOLID" version. 12/18/04 OK #if SIZE18_SOLID if notesize = 18 ++x perform setmus --x end #endif repeat x = d2 perform setmus #if SIZE18_SOLID if notesize = 18 --x perform setmus ++x end #endif #else if notesize >= 18 /* Added 11/18/03 to fill holes in lines OK /* New 12/18/04 changed from = 21 to >= 18 OK d2 = sp + syslen - slen z = 81 loop for x = sp to d2 step slen - 1 perform setmus ++x #if POSTSCRIPT #else perform setmus #endif repeat x = d2 perform setmus #if POSTSCRIPT #else --x perform setmus #endif else d2 = sp + syslen - slen z = 81 loop for x = sp to d2 step slen perform setmus repeat x = d2 perform setmus end #endif return *P 9. settie Purpose: Typeset typeset tie Inputs: x1 = x-object coordinate of first note y1 = y-object coordinate of first note (+1000 if on virtual staff) tspan = distance spanned by tie sitflag = situation flag f12 = staff number tpost_x = post adjustment to left x position added 04/20/03 OK tpost_y = post adjustment to y position " tpost_leng = post adjustment to right x position " Internal varibles: d1 = temporary variable d2 = temporary variable tiechar = first tie character textend = tie extention character hd = horizontal displacement vd = vertical displacement out = output string procedure settie int d1,d2,d3,d4,d5 int virtoff label STL(4) 1) decode y-object coordinate of first note virtoff = 0 if y1 > 700 y1 -= 1000 virtoff = vst(f12) end 2) complete sitflag d5 = hpar(60) d1 = sitflag - 1 & 0x0c >> 2 + 1 goto STL(d1) STL(1): /* tips down, space if y1 < vpar(2) ++sitflag else if y1 = vpar(3) and tspan > d5 /* e.g., C5 ++sitflag end end goto STLE STL(2): /* tips down, line if y1 < vpar(1) ++sitflag else if y1 = vpar(2) and tspan > d5 ++sitflag end end goto STLE STL(3): /* tips up, space if y1 > vpar(6) ++sitflag else if y1 = vpar(7) and tspan > d5 ++sitflag end end goto STLE STL(4): /* tips up, line if y1 > vpar(5) ++sitflag else if y1 = vpar(6) and tspan > d5 ++sitflag end end STLE: 3) from sitflag and tspan, get tiechar, hd and vd * putc SETTIE, x1 = ~x1 y1 = ~y1 tspan = ~tspan sitf = ~sitflag tspan -= tpost_x /* added 04/20/03 OK tspan += tpost_leng /* added 04/20/03 OK if tspan < hpar(61) /* minimum length depends on notesize putc Error: Tie too short to print putc SETTIE, x1 = ~x1 y1 = ~y1 tspan = ~tspan sitf = ~sitflag getc return end d1 = sitflag + 3 / 4 d3 = rem * 3 + 1 d2 = ( TIE_DISTS ) if tspan < ( (TIE_DISTS - 1) * hpar(62) + hpar(61) ) d2 = tspan - hpar(61) if hpar(62) = 3 ++d2 end d2 = d2 / hpar(62) + 1 /* row number for tie parameters end tiechar = tiearr(sizenum,d1,d2,d3) hd = tiearr(sizenum,d1,d2,d3+1) vd = tiearr(sizenum,d1,d2,d3+2) if sitflag > 8 vd = 0 - vd end 4) typeset tie x = x1 + hd + sp + tpost_x /* modified 04/20/03 etc. OK y = y1 - vd + sq(f12) + virtoff if tpost_y < 1000 y += tpost_y else tpost_y -= 10000 y = y1 + tpost_y + sq(f12) + virtoff end scf = 300 #if PRINT pz = revsizes(notesize) + TIE_OFFSET /* tie font number putp .b27 *p~x x~y Y.b27 (~pz X.b(tiechar) ... #else scx = x scy = y scb = tiechar perform charout #endif d1 = tiechar & 0x7f Revision 09/21/02: Trying to remove "magic numbers" from settie. OK if d1 = tiearr(sizenum,1,TIE_DISTS,4) /* staff free general long glyph textend = tiechar + 5 ++tiechar goto EXT end if d1 = tiearr(sizenum,1,TIE_DISTS,1) /* staff constrained general long glphy textend = tiechar + 1 tiechar += 2 goto EXT end if d1 > hpar(63) /* above glyph hpar(63), tie is compound ++tiechar #if PRINT putp .b(tiechar) ... #else scb = tiechar perform charout #endif end goto EXTa * EXT: vd = sitflag - 1 / 8 sitflag = rem + 1 hd = tspan vd = hd - expar(sitflag) + 32 / 8 /* was + 8 / 8 #if PRINT out = "" #else scb = textend #endif loop for tcnt = 1 to vd #if PRINT out = out // chr(textend) #else perform charout #endif repeat vd = hd - expar(sitflag) + 32 / 8 /* was + 16 / 8 vd = 40 - rem /* was 16 - rem #if PRINT putp ~out .b27 *p-~vd X.b(tiechar) ... #else scx -= vd scb = tiechar perform charout #endif * EXTa: #if PRINT pz = revsizes(notesize) putp .b27 (~pz X... #endif scf = notesize return *P 10. sethyph (level) Purpose: Typeset hyphons Inputs: level = level of text line (usually 1) x = absolute coordinate of terminating syllable y = absolute coordinate text line backloc(.) = location first space beyond last syllable or location of first hyphon on next line Internal varibles: a,b,c,d procedure sethyph (level) int level,pz /* pz added 03/15/04 int a,b,c,d /* a,b,c,d added 03/15/04 getvalue level #if PRINT 03/15/04 Code should have been written thus: a = revsizes(notesize) pz = XFonts(a,mtfont-29) out = esc // "(" // chs(pz) // "X" // esc // "*p" out = esc // "(" // chs(mtfont) // "X" // esc // "*p" out = out // chs(y) // "Y" #else scy = y #endif scf = mtfont a = x - backloc(level) * a = distance over which to set hyphons b = 3 * hpar(6) if a < b if a >= hpar(17) if backloc(level) = ibackloc(level) /* changed from hpar(15) 08/26/03 OK #if PRINT out = out // esc // "*p" // chs(backloc(level)) // "X-" #else scx = backloc(level) scb = ors("-") #endif #if PRINT putp ~out ... #else perform charout #endif if a < hpar(6) goto CM end end b /= 2 if a > b b = a - hpar(17) + 3 * 2 / 5 a = b + backloc(level) #if PRINT out = out // esc // "*p" // chs(a) // "X-" #else scx = a scb = ors("-") perform charout #endif a += b else a = a - hpar(17) + 3 / 2 + backloc(level) end #if PRINT out = out // esc // "*p" // chs(a) // "X-" putp ~out ... #else scx = a scb = ors("-") perform charout #endif else if x = hpar(9) if x = sysright /* sysright (from i-file) replaces hpar(9) 12/31/08 #if PRINT out = out // esc // "*p" // chs(backloc(level)) // "X-" putp ~out ... #else scx = backloc(level) scb = ors("-") perform charout #endif goto CM end end else if backloc(level) = ibackloc(level) /* changed from hpar(15) 08/26/03 OK b = 2 * a / hpar(6) + 1 c = a / b backloc(level) -= c a += c end b = a / hpar(6) c = a / b --b backloc(level) += c / 2 #if PRINT out = out // esc // "*p" // chs(backloc(level)) // "X-" putp ~out ... #else scx = backloc(level) scb = ors("-") perform charout #endif loop for d = 1 to b backloc(level) += c #if PRINT out = esc // "*p" // chs(backloc(level)) // "X-" putp ~out ... #else scx = backloc(level) scb = ors("-") perform charout #endif repeat end CM: #if PRINT pz = revsizes(notesize) putp .b27 (~pz X... #endif scf = notesize return *P 11. setunder (level) Purpose: Typeset underline Inputs: level = level of text line (usually 1) uxstop(.) = x-coordinate of end of line uxstart(.) = x-coord. of first space beyond last syllable or location of first hyphon on next line y = y-coordinate for text line underflag = execution flag, currently set for ties and melismas xbyte(.) = ending punctuation Internal varibles: a,b,c,d procedure setunder (level) int pz /* added 03/15/04 int a,b,c,d /* 03/15/04 adding a,b,c,d int level getvalue level if underflag = 0 return end x = uxstart(level) - hpar(19) #if PRINT a = revsizes(notesize) pz = XFonts(a,mtfont-29) putp .b27 (~pz X.b27 *p~x x~y Y... #else scx = x scy = y #endif scf = mtfont a = uxstop(level) - uxstart(level) * a = distance over which to set hyphons if a >= hpar(18) y -= vpar(13) #if PRINT out = esc // "*p" // chs(uxstart(level)) // "x" // chs(y) // "Y" #else scx = uxstart(level) scy = y scb = ors("_") #endif b = uxstop(level) - underspc(sizenum) d = underspc(sizenum) loop for c = uxstart(level) to b step d #if PRINT out = out // "_" #else perform charout #endif repeat #if PRINT putp ~out .b27 *p~b X_.b27 *p+5x+~vpar(13) Y... #else scx = b perform charout scx += 5 scy += vpar(13) #endif end if underflag = 1 and xbyte(level) <> "_" #if PRINT putp ~xbyte(level) ... #else scb = ors(xbyte(level)) perform charout #endif end #if PRINT pz = revsizes(notesize) putp .b27 (~pz X... #endif scf = notesize return *P 14. putslur Purpose: Typeset slur Inputs: (x1,y1) = starting note head (x2,y2) = terminating note head slur_edit_flag = flag indicating that y1 and/or y2 have been altered postx = horiz. movement of slur after it has been chosen posty = vert. movement of slur after it has been chosen addcurve = flag indicating the curvature should be added sitflag = situation flag bit clear bit set -------------- ------------- bit 0: full slur dotted slur bit 1: stock slur custom slur bit 2: first tip down first tip up (*) bit 3: second tip down second tip up (+) bit 4: compute stock slur hold stock slur (*) used on custom slurs only (+) used on stock slurs only bit 5: continuous slur broken slur /* 03/15/97 OK bits 8-15: size of break (0 to 255 dots, centered) Internal variables: a1,a3,a5,a6,a7,a8,a9,a10,a11,a12 c1,c2,c3,c4,c5,c6,c7 procedure putslur str line2.480 bstr tbt.2500 /* added 01/26/05 bstr tbt2.2500 /* added 01/26/05 int a1,a3,a5,a6,a7,a8,a9,a10,a11,a12 int save_y1,save_y2 int save_x1,save_x2 #if POSTSCRIPT str sbt1.2500 str sbt2.2500 int f,g,h int i,j,k #endif save_y1 = y1 /* added 01/03/05, etc. save_y2 = y2 save_x1 = x1 save_x2 = x2 determine case a9 = bit(2,sitflag) a1 = a9 * 2 + 1 /* 1,1,3,3 if y1 < y2 ++a1 /* 1,2,3,4 = tips down rising, tips down falling, etc. end determine method of dealing with slurs stock vs. custom if notesize = 14 a5 = 800 /* changed from 801 on 9-12-97 end if notesize = 6 a5 = 400 /* changed from 801 on 9-12-97 end if notesize = 21 a5 = 600 /* changed from 601 on 9-12-97 end if notesize = 18 /* New size-18 12/18/04 OK a5 = 800 end if notesize = 16 /* New size-16 12/31/08 not OK a5 = 800 end if x2 - x1 < a5 /* stock slurs SR5: a5 = vpar(10) + vpar20 - y1 * 2 + 1 / vpar(2) - 20 a6 = vpar(10) + vpar20 - y2 * 2 + 1 / vpar(2) - 20 a7 = abs(a5-a6) determine whether to use the parametric method of slur placement if a7 < 11 or (x2 - x1 < 100 and slur_edit_flag = 0) /* protopar file specific if a7 > 10 a7 -= 10 a7 = a7 + 20 * vpar(2) / 2 - vpar20 if a1 = 1 y1 -= a7 else if a1 = 2 y2 -= a7 else if a1 = 3 y2 += a7 else /* a1 = 4 y1 += a7 end end end goto SR5 end if a5 < 1 or a6 < 1 goto SR1 end if a5 > 11 or a6 > 11 goto SR2 end goto SR3 * adjust parameters upward SR1: a10 = a5 a11 = a6 if a6 < a5 a10 = a6 a11 = a5 end a10 = 1 - a10 /* minimum amount to raise pars if a7 < 10 a12 = a10 / 2 if a9 = 0 /* convex slur a10 += rem else if a11 + a10 > 3 a10 += rem end end end a5 += a10 a6 += a10 goto SR3 * adjust parameters downward SR2: a10 = a5 a11 = a6 if a6 > a5 a10 = a6 a11 = a5 end a10 -= 11 /* minimum amount to lower pars if a7 < 10 a12 = a10 / 2 if a9 = 1 /* concave slur a10 += rem else if a11 - a10 < 9 a10 += rem end end end a5 -= a10 a6 -= a10 SR3: get stock slur number and location SR4: a7 = x2 - x1 if notesize = 14 or notesize = 18 or notesize = 16 /* Modified (size-16) 12/31/08 not OK if a7 < 10 --x1 ++x2 goto SR4 end end if notesize = 21 if a7 < 15 --x1 ++x2 goto SR4 end end if notesize = 6 if a7 < 5 --x1 ++x2 goto SR4 end end if notesize = 14 or notesize = 18 or notesize = 16 /* Modified (size-16) 12/31/08 not OK a7 = x2 - x1 / 2 - 2 /* a7 should be less than 399 end if notesize = 21 a7 = x2 - x1 + 1 / 3 - 2 /* a7 should be less than 199 end if notesize = 6 a7 = x2 - x1 - 2 /* a7 should be less than 399 end if notesize = 14 or notesize = 6 or notesize = 18 or notesize = 16 /* Modified (size-16) 12/31/08 not OK if a7 >= 399 putc Program Error examine stop end end if notesize = 21 if a7 >= 199 putc Program Error examine stop end end if notesize = 14 line2 = MUSPRINT // "/bitmap/slurs/c/" end if notesize = 21 line2 = MUSPRINT // "/bitmap21/slurs/c/" end if notesize = 6 line2 = MUSPRINT // "/bitmap06/slurs/c/" end if notesize = 16 /* New (size-16) 12/31/08 not OK line2 = MUSPRINT // "/bitmap16/slurs/c/" end if notesize = 18 /* New (size-18) 12/18/04 OK line2 = MUSPRINT // "/bitmap18/slurs/c/" end line2 = "c:\wbh\res\mus\prnt\bitmap\slurs\protopar\c\" line2 = line2 // chs(a5) // "/" // chs(a6) open [3,1] line2 loop for a8 = 1 to a7 getf [3] repeat getf [3] c1 c2 c3 c4 c5 c6 c7 .t1 line2 if a1 < 3 x1 += c2 y1 -= c3 a3 = c4 else x1 += c5 y1 += c6 a3 = c7 end close [3] x = x1 + sp y = y1 + sq(f12) else /* we don't use parametric method if a1 < 3 /* tips down c1 = y1 / vpar(2) if y1 > vpar(1) and rem = 0 y1 = (c1 - 1) * vpar(2) + vpar(1) end c1 = y2 / vpar(2) if y2 > vpar(1) and rem = 0 y2 = (c1 - 1) * vpar(2) + vpar(1) end a3 = abs(y1 - y2) /* rise y1 -= vpar(2) else c1 = y1 / vpar(2) if y1 < vpar(8) and rem = 0 y1 += vpar(1) /* OK 04-24-95 end c1 = y2 / vpar(2) if y2 < vpar(8) and rem = 0 y2 += vpar(1) /* OK 04-24-95 end a3 = abs(y1 - y2) /* rise y1 += vpar(2) end x = x1 + sp + vpar(2) y = y1 + sq(f12) a7 = x2 - x1 - vpar(1) /* length if notesize = 14 or notesize = 18 or notesize = 16 /* Modified (size-16) 12/31/08 not OK For 14-dot slurs, the distribution of length for stock slurs is a follows Lengths Length Rise Number in dots increments increments of types (possible) ────────── ────────── ────────── ──────── 8 to 18 2 2 6 20 to 196 4 2 12 200 to 392 8 2 24 400 to 784 16 2 48 if a7 < 8 a7 = 8 end if a7 < 20 c1 = a7 / 2 if rem > 0 /* Fixing error: was if rem > 1 12/18/04 OK ++a7 end else if a7 < 200 c1 = a7 / 4 if rem > 1 ++x end a7 -= rem else if a7 < 400 c1 = a7 / 8 x += (rem >> 1) a7 -= rem else c1 = a7 / 16 x += (rem >> 1) a7 -= rem if rem > 11 x -= 8 a7 += 16 end if a7 >= 784 a7 = 784 end end end end For 14-dot slurs, 16-dot slurs and 18-dot slurs, (Comment modified (size-16) 12/31/08) not OK Slur number = (rise * 1200) + (length * 3) + type number number ranges from 8 to 143999 c1 = a3 / 4 a3 -= rem if a1 > 2 y += rem end a3 = a3 * 1200 + (a7 * 3) + 1 end if notesize = 21 For 21-dot slurs, the distribution of length for stock slurs is a follows Lengths Length Rise Number in dots increments increments of types (possible) ────────── ────────── ────────── ──────── 12 to 27 3 2 6 30 to 294 6 2 12 300 to 600 12 2 24 if a7 < 12 a7 = 12 end if a7 < 30 a7 = a7 + 1 / 3 * 3 else if a7 < 300 a7 = a7 + 1 / 6 * 6 rem >>= 1 x += rem else if a7 < 600 a7 = a7 + 3 / 12 * 12 rem >>= 1 x += rem else a7 = 600 end end end For 21-dot slurs, Slur number = (rise * 600) + (length * 2) + type number number ranges from 8 to 143999 c1 = a3 / 4 a3 -= rem if a1 > 2 y += rem end a3 = a3 * 600 + (a7 * 2) + 1 end if notesize = 6 For 6-dot slurs, the distribution of length for stock slurs is a follows Lengths Length Rise Number in dots increments increments of types (possible) ────────── ────────── ────────── ──────── 4 to 9 1 1 6 10 to 98 2 1 12 100 to 396 4 1 24 if a7 < 4 a7 = 4 end if a7 > 9 if a7 < 100 c1 = a7 / 2 a7 -= rem else if a7 < 396 c1 = a7 / 4 x += (rem >> 1) a7 -= rem else a7 = 396 end end end For 6-dot slurs, Slur number = (rise * 2400) + (length * 6) + type number number ranges from 8 to 143999 c1 = a3 / 2 a3 -= rem y += rem a3 = a3 * 2400 + (a7 * 6) + 1 end end x += postx y += posty a3 += addcurve /* new 6-30-93 if notesize = 14 if a3 > 120000 /* max rise = 96 goto NOSTOCK end end if notesize = 16 if a3 > 120000 /* max rise = 96 12/31/08 not OK goto NOSTOCK end end if notesize = 18 /* New (size-18) 12/18/04 OK if a3 > 115200 /* max rise = 92 goto NOSTOCK end end if notesize = 21 if a3 > 70000 goto NOSTOCK end end /* large gaps should now be supported a1 = case number a3 = stock slur number x = horizontal position y = vertical position Enter new code for acquiring and printing slur #if PRINT perform printslur (a1, a3, x, y, sitflag) #else a5 = 1 perform printslur_screen (a1, a3, x, y, a5, sitflag) #endif if a3 = 1000000 goto NOSTOCK end return end NOSTOCK: /* long slurs y1 = save_y1 /* added 01/03/05, etc. y2 = save_y2 x1 = save_x1 x2 = save_x2 if a1 < 3 /* tips down c1 = y1 / vpar(2) if y1 > vpar(1) and rem = 0 y1 = (c1 - 1) * vpar(2) + vpar(1) end c1 = y2 / vpar(2) if y2 > vpar(1) and rem = 0 y2 = (c1 - 1) * vpar(2) + vpar(1) end a3 = abs(y1 - y2) /* rise y1 -= vpar(2) else c1 = y1 / vpar(2) if y1 < vpar(8) and rem = 0 y1 += vpar(1) /* OK 04-24-95 end c1 = y2 / vpar(2) if y2 < vpar(8) and rem = 0 y2 += vpar(1) /* OK 04-24-95 end a3 = abs(y1 - y2) /* rise y1 += vpar(2) end x = x1 + sp + vpar(2) + postx y = y1 + sq(f12) + posty a7 = x2 - x1 - vpar(1) /* length perform make_longslur (a7,a3,a1) /* length,rise,smode /* return: a7 = offset, a3 = height y = y - a7 Code added 01/26/05 to implement dotted slurs in NOSTOCK situation 1) Determine a5 = maximum length of slur 2) Construct tbt = dotted mask for this slur if sitflag = 1 a5 = 0 loop for i = 1 to a3 tbt = cbi(longslur(i)) a6 = bln(tbt) if a6 > a5 a5 = a6 end repeat if a5 = 0 dputc Possible Error in constructing dotted mask a5 = 100 end a6 = a5 / gapsize if bit(0,a6) = 0 --a6 end xxxxxxxxxxx....xxxx....xxxx....xxxx....xxxx....xxxxxxxxxxx | odd number | a6 = largest odd number of intervals that will fit inside a5 a6 *= gapsize a7 = a5 - a6 a7 >>= 1 /* initial correction tbt = dup("1",a7) // dotted{1,a6} // dup("1",a7+10) /* mask end End of this 01/26/05 addition #if PRINT out = esc // "*p" // chs(x) // "x" out = out // chs(y) // "Y" out = out // esc // "*r1A" loop for i = 1 to a3 Code added 01/26/05 to implement dotted slurs in NOSTOCK situation if sitflag = 1 tbt2 = cbi(longslur(i)) /* bit equivalent of longslur(i) tbt2 = bnd(tbt2,tbt) /* and this with mask tbt2 = trm(tbt2) /* and trm to length longslur(i) = cby(tbt2) /* put this back in longslur(i) end End of this 01/26/05 addition c1 = len(longslur(i)) out = out // esc // "*b" // chs(c1) // "W" out = out // longslur(i) * putp ~out ... out = "" repeat out = out // esc // "*rB" * putp ~out ... #else scx = x scy = y c2 = 0 loop for i = 1 to a3 Code added 01/26/05 to implement dotted slurs in NOSTOCK situation if sitflag = 1 tbt2 = cbi(longslur(i)) /* bit equivalent of longslur(i) tbt2 = bnd(tbt2,tbt) /* and this with mask tbt2 = trm(tbt2) /* and trm to length longslur(i) = cby(tbt2) /* put this back in longslur(i) end End of this 01/26/05 addition bt(i) = cbi(longslur(i)) c1 = bln(bt(i)) if c1 > c2 c2 = c1 end repeat * #if POSTSCRIPT ++sst_cnt tput [SST,sst_cnt] Calling longslur at location <~scx ,~scy > ++sst_cnt tput [SST,sst_cnt] : f = c2 + 7 / 8 * 8 loop for i = 1 to a3 sbt1 = upk(bt(i)) sbt1 = sbt1 // pad(f) sbt2 = "" j = 0 loop for k = 1 to f if j = 0 j = 0x04 if sbt1{k} = "x" h = 0x08 else h = 0 end else if sbt1{k} = "x" h += j end j >>= 1 if j = 0 if h < 10 sbt2 = sbt2 // chs(h) else sbt2 = sbt2 // chr(55 + h) end end end repeat ++sst_cnt tput [SST,sst_cnt] ~sbt2 repeat ++sst_cnt tput [SST,sst_cnt] : #endif display slur contained in bt(a3) #if DSCROLL scx -= 500 /* added 11/29/09 if scx > 500 setb gstr,bt,scx,scy,a3,c2,1,3 end #else setb gstr,bt,scx,scy,a3,c2,1,3 #endif #endif return *P 15. puttuplet Purpose: Typeset tuplet and/or bracket Inputs: x1 = horizontal starting point of tuplet/bracket x2 = horizontal stopping point of tuplet/bracket y1 = vertical starting point y2 = vertical stopping point a1 = tuplet number sitflag = situation flag bit clear bit set ─────────── ───────── bit 0 no tuplet tuplet bit 1 no bracket bracket bit 2 tips down tips up bit 5 broken bracket continuous bracket /* 03/15/97 OK bit 6 number outside number inside bit 7 square bracket curved bracket Calling variables to internal procedures: a1,a4,a5 procedure puttuplet int f,xav,yav,h,k int t1,t2,t3,t4,t5,savex2 savex2 = x2 x2 += notesize if bit(1,sitflag) = 1 x2 = vpar(2) / 3 + x2 end a4 = x2 - x1 a4 = y2 - y1 * 60 / a4 xav = x1 + x2 / 2 yav = xav - x1 * a4 / 60 + y1 if and(3,sitflag) = 3 and yav < vpar(4) yav -= vpar(1) end xav = x at center of tuplet/bracket a4 = slope * 60 yav = y at center of tuplet/bracket Part I: tuplet present if bit(0,sitflag) = 1 x = xav y = yav + sq(f12) h = x - hpar(45) + (notesize / 3) k = x + hpar(45) - (notesize / 7) x = 0 - hpar(45) / 2 + x + sp New code (12/01/94) to deal with complex tuples t4 = a1 t1 = t4 / 1000 t2 = rem if t1 > 0 t3 = 2 if t2 > 9 ++t3 end if t1 > 9 ++t3 end t4 = hpar(45) * t3 + 1 >> 1 x -= t4 /* create space for colon + double digits h -= t4 k += t4 else t3 = 0 if t2 > 9 ++t3 end t4 = hpar(45) * t3 + 1 >> 1 x -= t4 /* create space for double digits h -= t4 k += t4 end if bit(1,sitflag) = 1 /* bracket present if bit(7,sitflag) = 1 /* curved bracket if bit(2,sitflag) = 0 /* tips down y -= (vpar(1) + 1 / 2) else /* tips up y += (vpar(1) + 1 / 2) end if bit(5,sitflag) = 0 /* broken bracket y -= (vpar(3) >> 2) end end 03/15/97 numbers below or above OK if bit(5,sitflag) = 1 /* continuous bracket if bit(7,sitflag) = 1 /* curved bracket if bit(6,sitflag) = 0 /* number outside if bit(2,sitflag) = 1 /* tips up y += vpar(2) else /* tips down y -= (vpar(5) + 1 / 2) end else /* number inside if bit(2,sitflag) = 1 /* tips up y -= vpar(3) else /* tips down y += (vpar(5) + 1 / 2) end end else /* square bracket if bit(6,sitflag) = 0 /* number outside if bit(2,sitflag) = 1 /* tips up y += vpar(3) else /* tips down y -= vpar(2) end else /* number inside if bit(2,sitflag) = 1 /* tips up y -= vpar(2) else /* tips down y += vpar(3) end end end h = xav + 2 /* eliminate space in bracket line k = xav - 2 end end #if PRINT putp .b27 *p~x x~y Y... #else scx = x scy = y #endif Put out numerator of tuple t3 = t2 / 10 t2 = rem if t3 > 0 a1 = t3 + 221 #if PRINT putp .b(a1) ... #else scb = a1 perform charout #endif end a1 = t2 + 221 #if PRINT putp .b(a1) ... #else scb = a1 perform charout #endif Put out denominator of tuple (if present) if t1 > 0 a1 = 249 /* colon #if PRINT putp .b(a1) ... #else scb = a1 perform charout #endif t3 = t1 / 10 t1 = rem if t3 > 0 a1 = t3 + 221 #if PRINT putp .b(a1) ... #else scb = a1 perform charout #endif end a1 = t1 + 221 #if PRINT putp .b(a1) ... #else scb = a1 perform charout #endif end end * * Part II: bracket present * if bit(1,sitflag) = 1 /* bracket present Square brackets if bit(7,sitflag) = 0 /* square bracket * 1) compute slope a5 = abs(a4) a5 = a5 + 3 / 5 if a5 > 6 a5 = 6 end if a5 = 5 a5 = 4 end if a5 = 6 a5 = 5 end if a4 > 0 a4 = a5 else a4 = 0 - a5 end yav -= vpar(40) * 2) case 1: broken bracket if bit(5,sitflag) = 0 a1 = h - x1 + 2 / 3 * 3 x1 = h - a1 f = 6 if a4 < 0 f = -6 end y1 = x1 - xav * a4 + 6 / 12 + yav x = x1 + sp y = y1 + sq(f12) perform brackethook perform bracketline a1 = x2 - k + 2 / 3 * 3 y1 = k - x1 * a4 + f / 12 + y1 x1 = k perform bracketline perform brackethook else * 3) case 2: continuous bracket a1 = x2 - x1 + 2 / 3 * 3 x1 = 0 - a1 - 1 / 2 + xav y1 = x1 - xav * a4 + 6 / 12 + yav x = x1 + sp y = y1 + sq(f12) perform brackethook perform bracketline perform brackethook end else Curved brackets (slurs) /* 03/15/97 OK Inputs: (x1,y1) = starting note head (x2,y2) = terminating note head slur_edit_flag = flag indicating that y1 and/or y2 have been altered postx = horiz. movement of slur after it has been chosen posty = vert. movement of slur after it has been chosen addcurve = flag indicating the curvature should be added sitflag = situation flag bit clear bit set -------------- ------------- bit 0: full slur dotted slur bit 1: stock slur custom slur bit 2: first tip down first tip up (*) bit 3: second tip down second tip up (+) bit 4: compute stock slur hold stock slur (*) used on custom slurs only (+) used on stock slurs only bit 5: continuous slur broken slur /* 03/15/97 OK bits 8-15: size of break (0 to 255 dots, centered) t1 = sitflag x2 = savex2 /* restore x2 to original if bit(2,t1) = 1 /* tips up sitflag = 12 posty = 0 - vpar(5) /* reason: y1 and y2 were supplied as endpoints else /* for square brackets, not the notes themselves sitflag = 0 /* this code is a cludge to correct for this posty = vpar(5) / 2 /* approximately. Rigorous solution would be end /* to set through the original oby's slur_edit_flag = 1 postx = 0 addcurve = 0 if bit(5,t1) = 0 /* broken slur t2 = k - h << 8 + 0x20 sitflag += t2 end perform putslur end end return * procedure brackethook if bit(2,sitflag) = 1 y = y - notesize + 2 end #if PRINT putp .b27 *p~x x~y Y.b89 ... #else scx = x scy = y scb = 89 perform charout #endif return *P 16. bracketline Purpose: typeset bracket line Inputs: a1 = length a4 = slope a5 = slope type 0,1,2,3,4,5 x1 = x starting point y1 = y starting point Outputs: x = x coordinate of end of line y = y coordinate of end of line procedure bracketline int pz /* added 03/15/04 int h,i,k if a1 = 0 return end x = x1 + sp y = y1 + sq(f12) #if PRINT pz = wedgefont(notesize) putp .b27 (~pz X.b27 *p~x x~y Y... #else scx = x scy = y #endif scf = 400 if a4 > 0 z = 184 + a5 end if a4 < 0 z = 164 + a5 end if a4 = 0 z = 161 end h = a1 / 12 k = rem if a4 = 0 loop for i = 1 to h x += 12 #if PRINT putp .b(z) ... #else scb = z perform charout #endif repeat else loop for i = 1 to h #if PRINT out = chr(z) // esc // "*p" #else scb = z perform charout #endif if a4 > 0 #if PRINT out = out // "+" // chs(a4) // "Y" #else scy += a4 #endif else h = 0 - a4 #if PRINT out = out // "-" // chs(h) // "Y" #else scy -= h #endif end x += 12 y += a4 #if PRINT putp ~out ... #endif repeat end if k > 0 if k = 9 if a4 < 0 h = a4 - 1 * 2 / 3 z += 5 end if a4 > 0 h = a4 + 1 * 2 / 3 z += 5 end if a4 = 0 h = 0 ++z end end if k = 6 if a4 < 0 h = a4 - 1 / 2 z += 10 end if a4 > 0 h = a4 + 1 / 2 z += 10 end if a4 = 0 h = 0 z += 2 end end if k = 3 if a4 < 0 h = a4 - 1 / 3 z += 15 end if a4 > 0 h = a4 + 1 / 3 z += 15 end if a4 = 0 h = 0 z += 3 end end #if PRINT putp .b(z) ... #else scb = z perform charout #endif x += k y += h end #if PRINT pz = revsizes(notesize) putp .b27 (~pz X... #endif scf = notesize return *P 17. putwedge Purpose: Typeset wedge Inputs: x1 = horizontal starting point of wedge x2 = horizontal stopping point of wedge y1 = vertical starting point y2 = vertical stopping point c1 = starting spread of wedge c2 = stopping spread of wedge procedure putwedge int pz /* added 03/15/04 int leng,slope,z1,clen,fullcnt int nex,h y1 -= vpar(1) y2 -= vpar(1) leng = x2 - x1 x = x1 + sp #if PRINT pz = wedgefont(notesize) putp .b27 (~pz X.b27 *p~x X... #else scx = x #endif scf = 400 * compute slope slope = c2 - c1 * 240 / leng slope = abs(slope) if slope < 8 slope = 8 end if c2 > c1 slope = slope + 2 / 4 else slope = slope + 3 / 4 end if slope > 20 slope = 20 end z1 = slope if c2 < c1 slope = 0 - slope end * compute character if z1 > 12 z1 = z1 - 13 / 2 + 13 end * compute length of character if z1 < 11 clen = 120 / z1 else clen = 128 / z1 end * compute number of full characters fullcnt = leng / clen * compute extension set nex = 0 h = rem - 30 if h > 0 ++nex tarr(nex) = 74 rem = h end h = rem - 20 if h > 0 ++nex tarr(nex) = 75 rem = h end h = rem - 10 if h > 0 ++nex tarr(nex) = 78 rem = h end if rem > 0 ++nex tarr(nex) = 88 - rem end * write out wedge . . . if slope > 0 /* cresc. h = c1 / 2 y2 += h y1 -= h z = z1 + 31 * -- top y = y1 + sq(f12) loop for h = 1 to fullcnt #if PRINT putp .b27 *p~y Y.b(z) ... #else scy = y scb = z perform charout #endif --y repeat loop for h = 1 to nex z = tarr(h) #if PRINT putp .b27 *p~y Y.b(z) ... #else scy = y scb = z perform charout #endif repeat * -- bottom #if PRINT out = esc // "*p" // chs(x) // "X" putp ~out ... #else scx = x #endif z = z1 + 51 y = y2 + sq(f12) loop for h = 1 to fullcnt #if PRINT putp .b27 *p~y Y.b(z) ... #else scy = y scb = z perform charout #endif ++y repeat loop for h = 1 to nex z = tarr(h) #if PRINT putp .b27 *p~y Y.b(z) ... #else scy = y scb = z perform charout #endif repeat else /* decresc. h = c2 / 2 y1 = y1 - h - fullcnt y2 = y2 + h + fullcnt * -- top y = y1 + sq(f12) loop for h = 1 to nex z = tarr(h) #if PRINT putp .b27 *p~y Y.b(z) ... #else scy = y scb = z perform charout #endif repeat z = z1 + 51 loop for h = 1 to fullcnt #if PRINT putp .b27 *p~y Y.b(z) ... #else scy = y scb = z perform charout #endif ++y repeat #if PRINT out = esc // "*p" // chs(x) // "X" putp ~out ... #else scx = x #endif * -- bottom y = y2 + sq(f12) loop for h = 1 to nex z = tarr(h) #if PRINT putp .b27 *p~y Y.b(z) ... #else scy = y scb = z perform charout #endif repeat z = z1 + 31 loop for h = 1 to fullcnt #if PRINT putp .b27 *p~y Y.b(z) ... #else scy = y scb = z perform charout #endif --y repeat end #if PRINT pz = revsizes(notesize) putp .b27 (~pz X... #endif scf = notesize return *P 18. putfigcon Purpose: Typeset figure continuation line Inputs: x1 = horizontal starting point of line x2 = horizontal stopping point of line a3 = vertical level of line y1 = additional vertical displacement from default height New 11/06/03 procedure putfigcon int g x = x1 + sp --a3 New code 11/06/03 adding figoff(.) and y1 y = vpar(37) * a3 + vpar(36) + sq(f12) + figoff(f12) + y1 #if PRINT putp .b27 *p~x x~y Y... #else scx = x scy = y #endif g = x2 - hpar(44) #if PRINT #else scb = 220 #endif loop while x1 <= g #if PRINT putp .b220 ... #else perform charout #endif x1 += hpar(44) repeat x = g + sp #if PRINT putp .b27 *p~x X.b220 ... #else scx = x perform charout #endif return *P 19. puttrans Purpose: Typeset octave transposition Inputs: x1 = horizontal starting point of transposition x2 = horizontal stopping point of transposition y1 = vertical level of transposition a1 = length of ending hook a3 = situation, 0 = 8av up, 1 = 8av down procedure puttrans int h,j,k x = x1 + sp y = y1 + sq(f12) #if PRINT putp .b27 *p~x x~y Y.b233 ... #else scx = x scy = y scb = 233 perform charout #endif x += hpar(42) #if PRINT putp .b27 *p~x X... #else scx = x #endif x1 += hpar(42) j = x2 - (hpar(43) >> 1) k = 0 #if PRINT #else scb = 91 #endif loop while x1 <= j k = 1 #if PRINT putp .b91 ... #else perform charout #endif x1 += hpar(43) repeat h = hpar(43) >> 1 x1 -= h if k = 1 if x1 <= j #if PRINT putp .b27 *p-~h X.b91 ... #else scx -= h perform charout #endif end if a1 > 0 j = hpar(43) >> 2 #if PRINT putp .b27 *p-~j X... #else scx -= j #endif if a1 < notesize a1 = notesize end if a3 = 1 k = a1 - 2 #if PRINT putp .b27 *p-~k Y... #else scy -= k #endif end loop while a1 > notesize #if PRINT putp .b89 .b27 *p+~notesize Y... #else scb = 89 perform charout scy += notesize #endif a1 -= notesize repeat k = notesize - a1 #if PRINT putp .b27 *p-~k Y.b89 ... #else scy -= k scb = 89 perform charout #endif end end return *P 20. putending Purpose: Typeset ending Inputs: x1 = horizontal starting point of ending x2 = horizontal stopping point of ending y1 = vertical level of ending a1 = length of start hook a2 = length of ending hook a3 = ending number, 0 = none procedure putending int pz /* added 03/15/04 int h, k int hh,kk /* added 04/12/09 if f12 > 1 if a3 > 9 /* New condition 04/25/09 a3 -= 10 else return end end x = x1 + sp y = y1 + sq(f12) #if PRINT putp .b27 *p~x x~y Y... #else scx = x scy = y #endif if a1 > 0 if a1 < notesize a1 = notesize end loop while a1 > notesize #if PRINT putp .b89 .b27 *p+~notesize Y... #else scb = 89 perform charout scy += notesize #endif a1 -= notesize repeat k = notesize - a1 #if PRINT putp .b27 *p-~k Y.b89 ... #else scy -= k scb = 89 perform charout #endif end if a3 > 0 #if PRINT h = revsizes(notesize) pz = XFonts(h,mtfont-29) putp .b27 *p+~vpar(1) x+~vpar(4) Y.b27 (~pz X~a3 .b46 ... New code 04/12/09: Fixing a bug in the placement of ending numbers hh = x + vpar(1) kk = y + vpar(4) putp .b27 *p~hh x~kk Y.b27 (~pz X~a3 .b46 ... putp .b27 (~h X... #else scx = x + vpar(1) scy = y + vpar(4) scf = mtfont out = chs(a3) perform stringout (out) scb = 46 perform charout #endif scf = notesize end #if PRINT putp .b27 *p~x x~y Y... #else scx = x scy = y #endif h = x2 - hpar(1) #if PRINT #else scb = 90 #endif loop while x1 <= h #if PRINT putp .b90 ... #else perform charout #endif x1 += hpar(1) repeat x = h + sp #if PRINT putp .b27 *p~x X.b90 ... #else scx = x perform charout #endif if a2 > 0 if a2 < notesize a2 = notesize end loop while a2 > notesize #if PRINT putp .b89 .b27 *p+~notesize Y... #else scb = 89 perform charout scy += notesize #endif a2 -= notesize repeat k = notesize - a2 #if PRINT putp .b27 *p-~k Y.b89 ... #else scy -= k scb = 89 perform charout #endif end return *P 21. putdashes Purpose: Typeset dashes Inputs: x1 = horizontal starting point of dashes x2 = horizontal stopping point of dashes y1 = vertical level of dashes a1 = spacing parameter a2 = font designator procedure putdashes int pz /* added 03/15/04 int h int a,b,c,d,e b = x2 - x1 if b < 0 return end x = x1 + sp + hyphspc(sizenum) y = y1 + sq(f12) scf = a2 #if PRINT a = revsizes(notesize) pz = XFonts(a,a2-29) putp .b27 (~pz X.b27 *p~x x~y Y.b45 ... putp .b27 (~pz X.b27 *p~x x~y Y.b173 ... #else scx = x scy = y scb = 45 scb = 173 perform charout #endif if a1 = 0 a = hyphspc(sizenum) * 5 c = b / a if c = 0 a1 = x2 - x1 c = 2 else if rem > hyphspc(sizenum) * 2 ++c end a1 = b / c end d = 1 else a = a1 c = b / a d = 0 end loop for e = 1 to c - 1 x += a1 #if PRINT putp .b27 *p~x X.b173 ... #else scx = x perform charout #endif if d = 1 b -= a1 --c if c > 0 a1 = b / c end end repeat #if PRINT pz = revsizes(notesize) putp .b27 (~pz X... #endif scf = notesize return *P 22. puttrill Purpose: Typeset long trill Inputs: x1 = horizontal starting point of trill x2 = horizontal stopping point of trill y1 = vertical level of trill a1 = situation 1 = no trill 2 = trill with no accidental 3 = trill with sharp 4 = trill with natural 5 = trill with flat 6 = trill with sharp following New 11/05/05 7 = trill with natural following " 8 = trill with flat following " procedure puttrill int h,t1,t2,k1 /* k1 is new 11/05/05 x = x1 + sp y = y1 + sq(f12) k1 = x1 /* localize x1 /* New 11/05/05 h = k1 /* New 11/05/05 #if PRINT out = esc // "*p" // chs(x) // "x" // chs(y) // "Y" #else scx = x scy = y #endif if a1 > 1 if a1 > 2 and a1 < 6 t1 = y - vpar(45) t2 = int("..389"{a1}) + 210 /* music font #if PRINT out = out // esc // "*p" // chs(t1) // "Y" // chr(t2) out = out // esc // "*p" // chs(y) // "Y" #else scb = t2 scy = t1 perform charout scy = y #endif end x += hpar(41) #if PRINT out = out // chr(236) // esc // "*p" // chs(x) // "X" #else scb = 236 perform charout scx = x #endif New code added to implement accidentals following a trill sign 11/05/05 if a1 > 5 and a1 < 9 x -= vpar(1) t1 = y - vpar(2) t2 = a1 + 185 /* music font (cue size) k1 += vpar(2) #if PRINT out = out // esc // "*p" // chs(x) // "X" out = out // esc // "*p" // chs(t1) // "Y" // chr(t2) x += vpar(3) out = out // esc // "*p" // chs(x) // "X" out = out // esc // "*p" // chs(y) // "Y" #else scx = x scy = t1 scb = t2 perform charout x += vpar(3) scx = x scy = y #endif end End of 11/05/05 New Code h = k1 + hpar(41) /* k1 replaces x1 11/05/05 end #if PRINT putp ~out ... out = "" #else scb = 237 #endif loop while h < x2 #if PRINT out = out // chr(237) #else perform charout #endif h += hpar(40) repeat #if PRINT putp ~out ... #endif return *P 23. sysline Purpose: Typeset left-hand system line Inputs: f11 = number of parts sq(1) = y coordinate of first part sq(f11) = y coordinate of last part sp = x-coordinate of beginning of line syscode = format for brace/bracket procedure sysline int pz /* added 03/15/04 int a1,a2,a3,a4,a5,a6,a7 int a8,a9,a10,a11,a12 /* added 03/11/06 if syscode = "" return end 1. typeset left-hand bar x = sp z = 82 y1 = sq(1) y2 = sq(f11) Adding code 11/13/03 to deal with mixed staff sizes OK a4 = notesize a3 = nsz(f11) /* notesize of staff for this termination a5 = a4 - a3 * 4 /* length correction if notesize <> a3 notesize = a3 /* set font size for computing vpar(44) perform init_par end y2 = sq(f11) + vpar(44) /* line thickness added 04-25-95 y2 -= a5 if notesize <> a4 notesize = a4 /* return to original font size perform init_par end brkcnt = 0 if f11 > 1 or vst(1) > 0 perform putbar (f11) end 2. typeset braces a2 = 0 loop for a1 = 1 to len(syscode) if syscode{a1} = "[" x = sp - hpar(46) y1 = sq(a2+1) end if syscode{a1} = "]" y2 = sq(a2) Adding code 11/13/03 to deal with mixed staff sizes OK a4 = notesize a3 = nsz(a2) /* notesize of staff for this termination a5 = a4 - a3 * 4 /* length correction y2 -= a5 z = 84 brkcnt = 0 perform putbar (a2) y = y1 z = 87 perform setmus y = y2 + vpar(8) + vst(a2) z = 88 perform setmus end if ".:,;" con syscode{a1} /* changed 11/13/03 OK ++a2 end repeat 3. typeset brackets x1 = x - hpar(47) a2 = 0 loop for a1 = 1 to len(syscode) if syscode{a1} = "{" y1 = sq(a2+1) end if syscode{a1} = "}" x = x1 y2 = sq(a2) + vpar(8) + vst(a2) Adding code 11/13/03 to deal with mixed staff sizes OK a4 = notesize a3 = nsz(a2) /* notesize of staff for this termination a5 = a4 - a3 * 4 /* length correction y2 -= a5 Adding code 03/11/06 to fully implement the 2-font system of brackets if notesize < 10 a7 = 66 a8 = 100 a9 = 3 a10 = 6 a11 = 96 else a7 = 132 a8 = 201 a9 = 6 a10 = 12 a11 = 192 end a3 = y2 - y1 There are three cases: a3 <= 201 (one glyph) granularity = 6 202 <= a3 <= 402 (two glyphs) granularity = 12 403 <= a3 <= 570 (three glyphs) granularity = 12 if a3 <= 201 if a3 <= a8 /* New 03/11/06 a4 = a3 + 2 / 6 * 6 /* actual length a4 = a3 + 2 / a9 * a9 /* actual length New 03/11/06 a5 = a4 - a3 / 2 /* delta / 2 y = y1 - a5 /* corrected value of y a5 = a4 / 6 + 20 /* font number a5 = a4 / a9 + 20 /* font number New 03/11/06 #if PRINT out = esc // "*p" // chs(x) // "x" // chs(y) // "Y" if notesize < 10 pz = SMALL_BRACK else pz = LARGE_BRACK end out = out // esc // "(" // chs(pz) // "X" // chr(a5) pz = revsizes(notesize) out = out // esc // "(" // chs(pz) // "X" putp ~out ... #else scx = x scy = y scb = a5 if scb < 33 #if BRACKET_WARNING putc WARNING: You are trying to typeset a bracket which is too short. putc This is sometimes the result of a faulty system code. putc If other problems occur as well, check system code first. #endif scb = 33 end scf = 320 perform charout scf = notesize #endif else if a3 <= 402 if a3 <= (a8 * 2) /* New 03/11/06 a4 = a3 + 5 / 12 * 12 /* actual length a4 = a3 + 5 / a10 * a10 /* actual length New 03/11/06 a5 = a4 - a3 / 2 /* delta / 2 y = y1 - a5 /* corrected value of y a5 = a4 / 12 + 10 * 2 /* font number a5 = a4 / a10 + 10 * 2 /* font number New 03/11/06 a6 = a4 / 2 /* y increment to second glyph #if PRINT out = esc // "*p" // chs(x) // "x" // chs(y) // "Y" if notesize < 10 pz = SMALL_BRACK else pz = LARGE_BRACK end out = out // esc // "(" // chs(pz) // "X" // chr(a5) out = out // esc // "*p+" // chs(a6) // "Y" // chr(a5+1) pz = revsizes(notesize) out = out // esc // "(" // chs(pz) // "X" putp ~out ... #else scx = x scy = y scb = a5 scf = 320 perform charout scy += a6 ++scb perform charout scf = notesize #endif else a4 = a3 + 5 / 12 * 12 /* actual length a4 = a3 + 5 / a10 * a10 /* actual length New 03/11/06 a5 = a4 - a3 / 2 /* delta / 2 y = y1 - a5 /* corrected value of y a5 = a4 / 12 - 5 * 3 + 1 /* font number a5 = a4 / a10 - 5 * 3 + 1 /* font number New 03/11/06 a6 = a4 - 384 /* y increment to third glyph a6 = a4 - (a11 * 2) /* y increment to third glyph New 03/11/06 #if PRINT out = esc // "*p" // chs(x) // "x" // chs(y) // "Y" if notesize < 10 pz = SMALL_BRACK else pz = LARGE_BRACK end out = out // esc // "(" // chs(pz) // "X" // chr(a5) out = out // esc // "*p+192Y" // chr(a5+1) out = out // esc // "*p+" // chs(a11) // "Y" // chr(a5+1) /* New 03/11/06 out = out // esc // "*p+" // chs(a6) // "Y" // chr(a5+2) pz = revsizes(notesize) out = out // esc // "(" // chs(pz) // "X" putp ~out ... #else scx = x scy = y New code 01/31/10 to enable display of extra-tall brackets. Code uses new glyph 124 in the bracket font. if a5 > 121 a5 = 115 scb = 115 scf = 320 perform charout /* New 03/11/06 scy += a11 a12 = scy + (a6 - a7 / 2 ) scb = 124 loop perform charout scy += 6 repeat while scy < a12 scy = a12 scb = 116 perform charout a12 = scy + a6 - (a6 - a7 / 2 ) scb = 124 scy += a7 loop perform charout scy += 6 repeat while scy < a12 scy = a12 scb = 117 perform charout scf = notesize else scb = a5 scf = 320 perform charout scy += 192 scy += a11 /* New 03/11/06 ++scb perform charout scy += a6 ++scb perform charout scf = notesize end #endif end end end if ".:,;" con syscode{a1} /* changed 11/13/03 OK ++a2 end repeat return *P 24. putbar (t1) Purpose: Typeset bar line Inputs: t1 = staff number of last line y1 = coordinate of top of line y2 = coordinate of last bar character brkcnt = number of breaks in bar barbreak(.,1) = y coordinate of top of break . barbreak(.,2) = y coordinage of bottom of break . x = x-coordinat of line z = font character procedure putbar (t1) int t1,t2 getvalue t1 if brkcnt = 0 t2 = y2 + vst(t1) loop for y = y1 to t2 step vpar(8) perform setmus repeat y = t2 perform setmus return end c3 = y1 loop for c1 = 1 to brkcnt c4 = barbreak(c1,1) - vpar(8) if c4 > c3 if c4 < y2 loop for y = c3 to c4 step vpar(8) perform setmus repeat y = c4 perform setmus c3 = barbreak(c1,2) end end repeat c4 = y2 + vst(t1) if c4 >= c3 loop for y = c3 to c4 step vpar(8) perform setmus repeat y = c4 perform setmus end return #if PRINT *P 26. printslur Purpose: read slur data from bigslur, compile and send slur to printer Input: ori case: 1,2,3 or 4 snum slur number x x location y y location sitflag situation flag bit 5: continuous slur broken slur bits 8-15: size of break (0 to 255 dots, centered) Output: snum = 1000000 if this routine fails for any reason procedure printslur (ori,snum,x,y,sitflag) str file.100,pointer.6,data.500,out.1000 bstr tbt.2500 int snum,ori int offset,datalen,nrows int slen,srise int bulge int i,j,n,x,y,t,maxn int dpnt,sdpnt int code,cnt,ndata(2),kdata(2) int sitflag int broksize /* 03/15/97 OK real rx * getvalue ori,snum,x,y,sitflag if bit(5,sitflag) = 1 /* 03/15/97 OK broksize = sitflag >> 8 else broksize = 0 end sitflag &= 0x01 if notesize = 14 file = MUSPRINT // "/bitmap/slurs/bigslur" end if notesize = 21 file = MUSPRINT // "/bitmap21/slurs/bigslur" end if notesize = 6 file = MUSPRINT // "/bitmap06/slurs/bigslur" end if notesize = 16 /* Notesize 16 bigslur is new 12/31/08 not OK file = MUSPRINT // "/bitmap16/slurs/bigslur" end if notesize = 18 /* Notesize 18 bigslur is new 12/18/04 OK file = MUSPRINT // "/bitmap18/slurs/bigslur" end file = "c:\wbh\res\mus\prnt\bitmap\slurs\bigslur" putc printslur called putc file = ~file putc ori = ~ori snum = ~snum x = ~x y = ~y open [3,5] file i = snum * 6 + 1 len(pointer) = 6 read [3,i] pointer offset = ors(pointer{1,4}) datalen = ors(pointer{5,2}) if datalen < 4 or datalen > 500 close [3] snum = 1000000 passback snum return end len(data) = datalen if offset = 0 close [3] snum = 1000000 passback snum return end read [3,offset] data n = ors(data{1,3}) if n <> snum close [3] snum = 1000000 passback snum return end nrows = ors(data{4}) slen = ors(data{5,2}) srise = ors(data{7}) bulge = ors(data{8}) if bulge > 127 /* added 01/03/05 bulge = 0 end slen += bulge /* added 11-19-92 if bulge > 0 x -= bulge end out = esc // "*p" // chs(x) // "x" i = 0 /* look for vert shift if ori = 1 i = nrows - 1 else if ori = 2 i = nrows - 1 - srise else if ori = 3 i = srise end end end y = y - i out = out // chs(y) // "Y" out = out // esc // "*r1A" putp ~out ... out = "" * if ori = 1 or ori = 2 dpnt = 9 else if slen < 256 dpnt = len(data) - 1 else dpnt = len(data) - 2 end end * maxn = 0 loop for i = 1 to nrows if slen < 256 cnt = 1 code = ors(data{dpnt,2}) if code & 0x8000 <> 0 cnt = 2 if ori > 2 dpnt = dpnt - 2 code = ors(data{dpnt,2}) end end sdpnt = dpnt loop for j = 1 to cnt code = code & 0x7fff rx = -.5 + sqt(flt(code)*2.0+.25) t = fix(rx+.0000001) kdata(j) = 255 - t t = t + 1 * t / 2 ndata(j) = code - t dpnt = dpnt + 2 if j < cnt code = ors(data{dpnt,2}) end repeat if ori > 2 dpnt = sdpnt - 2 end else cnt = 1 code = ors(data{dpnt,3}) if code & 0x800000 <> 0 cnt = 2 if ori > 2 dpnt = dpnt - 3 code = ors(data{dpnt,3}) end end sdpnt = dpnt loop for j = 1 to cnt code = code & 0x7fffff rx = -.5 + sqt(flt(code)*2.0+.25) t = fix(rx+.0000001) kdata(j) = 1000 - t t = t + 1 * t / 2 ndata(j) = code - t dpnt = dpnt + 3 if j < cnt code = ors(data{dpnt,3}) end repeat if ori > 2 dpnt = sdpnt - 3 end end * j = ndata(1) + kdata(1) tbt = zpd(ndata(1)) // npd(j) if cnt = 2 j = ndata(2) + kdata(2) tbt = tbt // zpd(ndata(2)) // npd(j) end if ori = 2 or ori = 3 tbt = tbt // zpd(slen) tbt = rev(tbt) tbt = trm(tbt) end bt(i) = tbt tbt = trm(tbt) n = bln(tbt) if n > maxn maxn = n end repeat if sitflag = 1 j = maxn / gapsize if bit(0,j) = 0 --j end xxxxxxxxxxx....xxxx....xxxx....xxxx....xxxx....xxxxxxxxxxx | odd number | j = largest odd number of intervals that will fit inside maxn j *= gapsize i = maxn - j i >>= 1 /* initial correction tbt = dup("1",i) // dotted{1,j} // dup("1",i+10) /* mask end if broksize > 0 /* 03/15/97 OK j = maxn - broksize >> 1 if j < 0 j = 0 end i = maxn - j - j tbt = dup("1",j) // dup("0",i) // dup("1",j) end loop for i = 1 to nrows if sitflag = 1 or broksize > 0 /* 03/15/97 OK bt(i) = bnd(bt(i),tbt) end n = bln(bt(i)) + 7 / 8 out = esc // "*b" // chs(n) // "W" out = out // cby(bt(i)) putp ~out ... repeat out = out // esc // "*rB" * close [3] putp ~out ... return * #else *P 26a. printslur_screen Purpose: read slur data from bigslur, compile and send slur to screen Input: ori case: 1,2,3 or 4 snum slur number x x location y y location mode 1 = display, 0 = clear (cancel) sitflag situation flag bit 5: continuous slur broken slur bits 8-15: size of break (0 to 255 dots, centered) procedure printslur_screen (ori,snum,x,y,mode,sitflag) str file.100,pointer.6,data.500 bstr bt.800(150) This is now global int snum,ori int offset,datalen,nrows int slen,srise int bulge int h,i,j,k,n,x,y,t,maxn int dpnt,sdpnt int code,cnt,ndata(2),kdata(2) int mode,sitflag int broksize /* 03/15/97 OK real rx int scx2 /* added 11/29/09 #if POSTSCRIPT str sbt.800 #endif * getvalue ori,snum,x,y,mode,sitflag if bit(5,sitflag) = 1 /* 03/15/97 OK broksize = sitflag >> 8 else broksize = 0 end sitflag &= 0x01 file = "c:\wbh\res\mus\prnt\bitmap\slurs\bigslur" if notesize = 14 file = MUSPRINT // "/bitmap/slurs/bigslur" end if notesize = 21 file = MUSPRINT // "/bitmap21/slurs/bigslur" end if notesize = 6 file = MUSPRINT // "/bitmap06/slurs/bigslur" end if notesize = 16 /* Notesize 16 bigslur is new 12/31/08 not OK file = MUSPRINT // "/bitmap16/slurs/bigslur" end if notesize = 18 /* Notesize 18 bigslur is new 12/18/04 OK file = MUSPRINT // "/bitmap18/slurs/bigslur" end putc printslur called putc file = ~file putc ori = ~ori snum = ~snum x = ~x y = ~y getc open [1,5] file i = snum * 6 + 1 len(pointer) = 6 read [1,i] pointer offset = ors(pointer{1,4}) datalen = ors(pointer{5,2}) if datalen < 4 or datalen > 500 close [1] snum = 1000000 passback snum return end len(data) = datalen if offset = 0 close [1] snum = 1000000 passback snum return end read [1,offset] data n = ors(data{1,3}) if n <> snum close [1] snum = 1000000 passback snum return end nrows = ors(data{4}) slen = ors(data{5,2}) srise = ors(data{7}) bulge = ors(data{8}) if bulge > 127 /* added 01/03/05 bulge = 0 end slen += bulge /* added 11-19-92 if bulge > 0 x -= bulge end i = 0 /* look for vert shift if ori = 1 i = nrows - 1 else if ori = 2 i = nrows - 1 - srise else if ori = 3 i = srise end end end y = y - i /* move screen cursor to point <x,y> scx = x scy = y * if ori = 1 or ori = 2 dpnt = 9 else if slen < 256 dpnt = len(data) - 1 else dpnt = len(data) - 2 end end * maxn = 0 loop for i = 1 to nrows if slen < 256 cnt = 1 code = ors(data{dpnt,2}) if code & 0x8000 <> 0 cnt = 2 if ori > 2 dpnt = dpnt - 2 code = ors(data{dpnt,2}) end end sdpnt = dpnt loop for j = 1 to cnt code = code & 0x7fff rx = -.5 + sqt(flt(code)*2.0+.25) t = fix(rx+.0000001) kdata(j) = 255 - t t = t + 1 * t / 2 ndata(j) = code - t dpnt = dpnt + 2 if j < cnt code = ors(data{dpnt,2}) end repeat if ori > 2 dpnt = sdpnt - 2 end else cnt = 1 code = ors(data{dpnt,3}) if code & 0x800000 <> 0 cnt = 2 if ori > 2 dpnt = dpnt - 3 code = ors(data{dpnt,3}) end end sdpnt = dpnt loop for j = 1 to cnt code = code & 0x7fffff rx = -.5 + sqt(flt(code)*2.0+.25) t = fix(rx+.0000001) kdata(j) = 1000 - t t = t + 1 * t / 2 ndata(j) = code - t dpnt = dpnt + 3 if j < cnt code = ors(data{dpnt,3}) end repeat if ori > 2 dpnt = sdpnt - 3 end end * j = ndata(1) + kdata(1) bt(i) = zpd(ndata(1)) // npd(j) if cnt = 2 j = ndata(2) + kdata(2) bt(i) = bt(i) // zpd(ndata(2)) // npd(j) end if ori = 2 or ori = 3 bt(i) = bt(i) // zpd(slen) bt(i) = rev(bt(i)) bt(i) = trm(bt(i)) end n = bln(bt(i)) if n > maxn maxn = n end repeat if sitflag = 1 j = maxn / gapsize if bit(0,j) = 0 --j end xxxxxxxxxxx....xxxx....xxxx....xxxx....xxxx....xxxxxxxxxxx | odd number | j = largest odd number of intervals that will fit inside maxn j *= gapsize i = maxn - j i >>= 1 /* initial correction bt(250) = dup("1",i) // dotted{1,j} // dup("1",i+10) /* mask loop for i = 1 to nrows bt(i) = bnd(bt(i),bt(250)) repeat end if broksize > 0 /* 03/15/97 OK j = maxn - broksize >> 1 if j < 0 j = 0 end i = maxn - j - j bt(250) = dup("1",j) // dup("0",i) // dup("1",j) loop for i = 1 to nrows bt(i) = bnd(bt(i),bt(250)) repeat end * close [1] #if POSTSCRIPT ++st_cnt tput [ST,st_cnt] Calling for a slur at <~scx ,~scy > ++st_cnt tput [ST,st_cnt] : loop for i = 1 to nrows sbt = upk(bt(i)) ++st_cnt tput [ST,st_cnt] ~sbt repeat ++st_cnt tput [ST,st_cnt] : #endif 01/05/09 Code below added back to POSTSCRIPT case, because we need the "dots" to determine the bounding box. #else /* display slur contained in bt(nrows) New 11/29/09 This variation includes the "scrolling" for dscroll #if DSCROLL if mode = 1 if h_shift = 0 setb gstr,bt,scx,scy,nrows,maxn,1,3 else scx2 = scx - h_shift if scx2 > 500 setb gstr,bt,scx2,scy,nrows,maxn,1,3 end end else clearb gstr,bt,scx,scy,nrows,maxn,1,3 end #else if mode = 1 setb gstr,bt,scx,scy,nrows,maxn,1,3 else clearb gstr,bt,scx,scy,nrows,maxn,1,3 end #endif #endif return * #endif End of if PRINT (for procedures printslur and printslur_screen) *P 32. barline Purpose: Typeset bar line Inputs: f11 = number of parts sq(1) = y coordinate of first part sq(f11) = y coordinate of last part x = x-coordinate of line z = bar character syscode = format for bar govstaff = governing staff for size (length) of barline nsz(.) = notesizes for each staff in the systme Procedure rewritten 11/13/03 to deal with mixed staff sizes OK procedure barline int a1,a2,a3,a4,a5 if z = 86 /* Case: dotted bar line cannot connect staff lines loop for a1 = 1 to f11 y = sq(a1) a4 = nsz(a1) if notesize <> a4 notesize = a4 /* set font size for segment perform init_par end perform setmus repeat else a2 = 0 loop for a1 = 1 to len(syscode) if "[(" con syscode{a1} a4 = 0 /* this will become the font size for this segment y1 = sq(a2+1) end if "])" con syscode{a1} If a4 is not determined at this point, set it to the default if a4 = 0 a4 = nsz(a2) /* font size of bottom staff in this segment end a3 = nsz(a2) /* notesize of staff for this termination a5 = a4 - a3 * 4 /* length correction if notesize <> a3 notesize = a3 /* set font size for computing vpar(44) perform init_par end y2 = sq(a2) + vpar(44) /* line thickness added 04-25-95 y2 -= a5 if notesize <> a4 notesize = a4 /* set font size for segment perform init_par end perform putbar (a2) end if ".:,;" con syscode{a1} ++a2 if mpt > 2 if a4 = 0 a4 = nsz(a2) else if nsz(a2) > a4 a4 = nsz(a2) end end end end repeat end return PEND ************************************************** procedure strip3 if line con " " line{mpt} = "." end if line con " " line{mpt} = "." end if line con " " line = line{mpt+1..} else line = "" end return * procedure strip6 if line con " " line{mpt} = "." end if line con " " line{mpt} = "." end if line con " " line{mpt} = "." end if line con " " line{mpt} = "." end if line con " " line{mpt} = "." end if line con " " line = line{mpt+1..} else line = "" end return * procedure strip8 if line con " " line{mpt} = "." end if line con " " line{mpt} = "." end if line con " " line{mpt} = "." end if line con " " line{mpt} = "." end if line con " " line{mpt} = "." end if line con " " line{mpt} = "." end if line con " " line{mpt} = "." end if line con " " line = line{mpt+1..} else line = "" end return * procedure save1 if htype = "V" structure of transp super-object: 4. situation: 0=8av up, 1=8av down 5. horiz. disp. from obj1 6. horiz. disp. from obj2 7. vert. disp. from obj1 8. length of right vertical hook tline = txt(line,[' '],lpt) a3 = int(tline) tline = txt(line,[' '],lpt) x1 = int(tline) + superdata(k,1) tline = txt(line,[' '],lpt) x2 = int(tline) + superdata(k,3) tline = txt(line,[' '],lpt) y1 = int(tline) /* + superdata(k,2) if y1 > 700 y1 -= 1000 y1 += vst(f12) end tline = txt(line,[' '],lpt) a1 = int(tline) perform puttrans return end if htype = "E" structure of ending super-object: 4. ending number (0 = none) 5. horiz. disp. from obj1 6. horiz. disp. from obj2 7. vert. disp. from staff lines 8. length of left vertical hook 9. length of right vertical hook tline = txt(line,[' '],lpt) a3 = int(tline) tline = txt(line,[' '],lpt) x1 = int(tline) + superdata(k,1) tline = txt(line,[' '],lpt) x2 = int(tline) + superdata(k,3) tline = txt(line,[' '],lpt) y1 = int(tline) tline = txt(line,[' '],lpt) a1 = int(tline) tline = txt(line,[' '],lpt) a2 = int(tline) perform putending return end if htype = "D" structure of dashes super-object: 4. horiz. disp. from obj1 5. horiz. disp. from obj2 6. vert. disp. from staff lines 7. spacing parameter 8. font designator tline = txt(line,[' '],lpt) x1 = int(tline) + superdata(k,1) tline = txt(line,[' '],lpt) x2 = int(tline) + superdata(k,3) tline = txt(line,[' '],lpt) y1 = superdata(k,2) if y1 > 700 y1 = vst(f12) else y1 = 0 end y1 += int(tline) tline = txt(line,[' '],lpt) a1 = int(tline) tline = txt(line,[' '],lpt) a2 = int(tline) perform putdashes return end if htype = "R" structure of trill super-object: 4. situation: 1 = no trill, only ~~~~ 2 = trill with ~~~~ 3 = tr ~~~~ with sharp above 4 = tr ~~~~ with natural above 5 = tr ~~~~ with flat above 5. horiz. disp. from object 1 6. horiz. disp. from object 2 7. vert. disp. from object 1 tline = txt(line,[' '],lpt) a1 = int(tline) tline = txt(line,[' '],lpt) x1 = int(tline) + superdata(k,1) tline = txt(line,[' '],lpt) x2 = int(tline) + superdata(k,3) tline = txt(line,[' '],lpt) y1 = int(tline) + superdata(k,2) if y1 > 700 y1 -= 1000 y1 += vst(f12) end perform puttrill return end if htype = "W" structure of wedge super-object: 4. left spread 5. right spread 6. horiz. disp. from obj1 7. beg. vert. disp. from staff 8. horiz. disp. from obj2 9. end. vert. disp. from staff tline = txt(line,[' '],lpt) c1 = int(tline) tline = txt(line,[' '],lpt) c2 = int(tline) tline = txt(line,[' '],lpt) x1 = int(tline) + superdata(k,1) tline = txt(line,[' '],lpt) c3 = superdata(k,2) if c3 > 700 c3 = vst(f12) else c3 = 0 end y1 = int(tline) + c3 tline = txt(line,[' '],lpt) x2 = int(tline) + superdata(k,3) a1 = x2 - x1 if a1 < hpar(39) x2 = x1 + hpar(39) end tline = txt(line,[' '],lpt) y2 = int(tline) + c3 perform putwedge return end return ╔═════════════════════════════════════════════════════════╗ ║ L O N G S L U R C O N S T R U C T I O N ║ ╚═════════════════════════════════════════════════════════╝ #define MAPZ 2500 procedure make_longslur (length,rise,smode) str out.MAPZ str map.MAPZ(250),zeros.MAPZ bstr temp.MAPZ int g,h,i,j,k,p,q,s,t int hh,ii,jj,kk int x1,x2,y1,y2 int rise,length int pc,pd,pe,pf,pg,ph int scnt int smode real delta,alpha,beta,delta2,beta2 real X,x,Y,y,z,Cx,Cy,R,L,H,D,W,Q,P,A,B,Ca,Cb real a,b,c real xx,yy,u,v real inpx,outpx,inpy,outpy,ind,outd real sx(8000),sy(8000) real PP,QQ real SCALE real rtype zeros = zpd(MAPZ) * I. Determine scaling factor if notesize = 14 SCALE = 1.0 else SCALE = flt(notesize) / 14.0 end * II. Get rise and length limits getvalue length,rise,smode i = length - 1 X = flt(i) Y = flt(rise) X = X / SCALE /* 05-12-95 all computations done Y = Y / SCALE /* at original size. length = length * 14 / notesize /* clear slur array loop for i = 1 to 250 map(i) = pad(MAPZ) repeat Beginning of slur generation ┌────────────────────────────────────────────────┐ │ P A R A M E T R I C M A G I C │ └────────────────────────────────────────────────┘ rtype = 2.0 if X < 600.0 H = X * .03 + 9.0 + (1.9 * rtype) else H = 27.0 + (1.9 * rtype) end if X > 1200.0 H = H + (X - 1200.0 / 200.0) end rtype -= 1.0 L = X * X + (Y * Y) L = sqt(L) a = rtype / 75. W = L * (.66 - a) /* experimental value compute R, P, A, B, Cx, Cy, Ca, Cb and check limitations 1. Q: if X > 300.0 Q = 15.0 else Q = 13.0 end LS_PAA: 2. R = L*L/Q/8 + Q/2 x = L * L / Q / 8.0 y = Q / 2.0 R = x + y 3. P = R - (R*R - (W*W/4))^1/2 component of height from middle section x = (R * R) - (W * W / 4.0) P = R - sqt(x) y = (L - W) / 2.0 + P if H > y H = y end if H < Q H = dec(Q) + .5 end 4. A = (L - W) / 2 B = H - P <A,B> = transition point A = (L - W) / 2.0 B = H - P 5. Cx = X/2 Cy = R - H <Cx,Cy> = center of main arc Cx = L / 2.0 Cy = H - R /* a negative number 6. Compute <Ca,Cb> = center of starting arc [ B*(Cx-A)/(Cy-B) + (A*A + B*B)/2/A - A ] Cb = ───────────────────────────────────────── [ B/A + (Cx-A)/(Cy-B) ] Ca = (A*A + B*B)/2/A - B*(Cb)/ A a = (Cx - A) / (Cy - B) b = (A * A) + (B * B) b = b / 2.0 / A Cb = (B * a + b - A) / (B / A + a) Ca = b - (B * Cb / A) normalize D-function xx = L / 2.0 D = sqt(xx) / 4.8 if D > 1.50 D -= .16 /* radical if H / L > .200 D -= .10 end end if D > 1.70 D = D - 1.70 * .2 + 1.70 end if D > 1.95 D = D - 1.95 * .3 + 1.95 end if D > 2.25 D = D - 2.25 * .4 + 2.25 end ┌────────────────────────────────────────┐ │ S W E E P L O O P 1 │ └────────────────────────────────────────┘ ║ sqt(A*A + B*B) ║ 1. compute beta = 2 * sin-1║─────────────────────║ sweep angle ║ 2*sqt(Ca*Ca + Cb*Cb)║ a = A * A + (B * B) b = Ca * Ca + (Cb * Cb) c = sqt(b) beta = rtype / 7.5 if L >= 400. delta = L * .001 else delta = L * .006 - 2.00 end if R / c > 3.00 - beta + delta Q += .1 if Q < H - .5 goto LS_PAA end end c = sqt(a/b) beta = 2.0 * ars(c/2.0) 2. compute delta so that sweep hits every dot a = sqt(a) /* length of arc (approx) delta = beta / a / 2.0 scnt = 0 alpha = 0.0 3. begin sweep LS_SW1A: a = 1.0 - cos(alpha) b = sin(alpha) x = Ca * a - (Cb * b) y = Ca * b + (Cb * a) if x < A ++scnt sx(scnt) = x sy(scnt) = y alpha += delta goto LS_SW1A end ┌────────────────────────────────────────┐ │ S W E E P L O O P 2 │ └────────────────────────────────────────┘ 1. compute beta2 = sin-1{ [(L/2)-A] / R } a = L / 2.0 - A / R beta2 = ars(a) 2. compute delta so that sweep hits every dot delta2 = beta2 * 2.0 / W / 2.0 alpha = 0.0 - beta2 3. begin sweep LS_SW2A: x = R * sin(alpha) + Cx y = R * cos(alpha) + Cy if x < L - A and scnt < 7999 /* added 11/29/09 ++scnt sx(scnt) = x sy(scnt) = y alpha += delta2 goto LS_SW2A end ┌────────────────────────────────────────┐ │ S W E E P L O O P 3 │ └────────────────────────────────────────┘ 1. beta and delta already computed alpha = beta 2. begin sweep LS_SW3A: a = 1.0 - cos(alpha) b = sin(alpha) x = L - (Ca * a) + (Cb * b) y = Ca * b + (Cb * a) if x < L and scnt < 7999 /* added 11/29/09 ++scnt sx(scnt) = x sy(scnt) = y alpha -= delta goto LS_SW3A end ++scnt sx(scnt) = L sy(scnt) = 0.0 ┌──────────────────────────────────────────────────────────────┐ │ E N D O F S W E E P S. C O N S T R U C T S L U R │ └──────────────────────────────────────────────────────────────┘ 1. rotate data to produce rise a = X / L b = Y / L loop for i = 1 to scnt x = sx(i) * a - (sy(i) * b) y = sx(i) * b + (sy(i) * a) sx(i) = x sy(i) = y repeat 2. setup thickness parameters pc = length * 60 / (length + 400) /* carefully worked out formula 05/13/95 pd = pc * 3 / 10 pe = scnt - pc pf = scnt - pd if notesize = 21 /* disable this feature for notesize = 21 12/03/08 pc = 1 pe = scnt end pg = 50 * scnt / 100 if length < 400 ph = 0 else ph = (length - 400) * scnt * 4 / 40000 end 3. compute ind, outd loop for i = 1 to scnt if i < pc /* left hand side of slur ind = 0.6 if notesize = 21 ind = 1.3 end if i < pd /* extreme left end if notesize = 16 /* New size-16 12/31/08 outd = .4 * flt(i) / flt(pc) else outd = flt(i) / flt(pc) + .1 end else outd = 0.4 end if notesize = 14 outd += .4 end if notesize = 16 /* New size-16 12/31/08 outd += .3 end if notesize = 18 /* New size-18 12/18/04 outd += .3 end if notesize = 21 outd += .3 end goto LS_PCD end if i > pe /* right hand side of slur ind = 0.6 if i >= pf /* extreme right end j = scnt - i if notesize = 16 /* New size-16 12/31/08 outd = 0.4 * flt(j) / flt(pc) else outd = flt(j) / flt(pc) + .1 end else outd = 0.4 end if notesize = 14 outd += .4 end if notesize = 16 /* New size-16 12/31/08 outd += .3 end if notesize = 18 /* New size-18 12/18/04 outd += .3 end goto LS_PCD end /* middle of slur if i > pg + ph /* right side j = pe - i s = pe - pg - ph else /* left side if i < pg - ph j = i - pc s = pg - pc - ph else s = 10000 j = 9999 end end b = flt(j) * ars(1.0) / flt(s) /* max(b) = sin-1(1) a = sin(b) if notesize = 14 outd = D - .8 * a + .8 ind = D - .6 * a + .6 end New 12/31/08 parameters for notesize 16 (based on create16.z) if notesize = 16 outd = D - 0.1 * a + 0.4 ind = D - 0.6 * a + 0.6 outd += .29000 ind += .29000 end New 12/18/04 parameters for notesize 18 (based on create18.z) if notesize = 18 outd = D - 0.7 * a + 0.7 ind = D - 0.6 * a + 0.6 outd += .69000 ind += .79000 end 01/26/06 parameters added for notesize 6 if notesize = 6 outd = D - 0.8 * a + 0.8 ind = D - 0.6 * a + 0.6 outd += .39000 ind += .49000 end 12/03/08 parameters changed for notesize 21 if notesize = 21 outd = D - 0.6 * a + 0.6 ind = D - 1.0 * a + 1.0 outd += .29000 ind += .89000 end 4. compute outside point, inside point LS_PCD: x = sx(i) y = sy(i) give finite width to slur if i < scnt u = sx(i+1) v = sy(i+1) else u = x v = y end if i > 1 xx = sx(i-1) yy = sy(i-1) else xx = x yy = y end u -= xx /* delta x v -= yy /* delta y c = u * u + (v * v) c = sqt(c) /* delta hypotinus a = outd / c b = ind / c outpx = x - (a * v) outpy = y + (a * u) inpx = x + (b * v) inpy = y - (b * u) 5. compute box coordinates if outpx < inpx a = outpx outpx = inpx inpx = a end if outpy < inpy a = outpy outpy = inpy inpy = a end outpx = outpx + 30.0 /* - .5 inpx = inpx + 30.0 /* - .5 outpy = outpy + 20.0 - 1.0 inpy = inpy + 20.0 + .5 For notesize = 21, it appears that scaling here is better if notesize = 21 inpx = inpx * SCALE outpx = outpx * SCALE inpy = inpy * SCALE outpy = outpy * SCALE end x1 = fix(inpx) x2 = fix(outpx) y1 = fix(inpy) y2 = fix(outpy) if x2 - x1 < 2 ++y2 /* radical end 6. set points inside box to 1 (with inverted vertical axis) Here is where you scale the slur back to its original size if notesize <> 21 x1 = x1 * notesize / 14 x2 = x2 * notesize + 7 / 14 y1 = y1 * notesize / 14 y2 = y2 * notesize + 7 / 14 end if y2 > 249 y2 = 249 end if x2 > 2500 /* added 11/29/09 x2 = 2500 end loop for j = y1 to y2 q = 250 - j loop for k = x1 to x2 map(q){k} = "x" repeat repeat repeat End of slur generation /* determine size of map display loop for i = 1 to 250 map(i) = trm(map(i)) if map(i) <> "" goto LS_CE end repeat LS_CE: y1 = i loop for j = i to 249 map(j+1) = trm(map(j+1)) if map(j) = "" and map(j+1) = "" goto LS_CF end repeat LS_CF: y2 = j - 1 loop for j = 1 to MAPZ loop for i = y1 to y2 if map(i){j} = "x" goto LS_CH end repeat repeat LS_CH: x1 = j x2 = 0 loop for i = y1 to y2 if x2 < len(map(i)) x2 = len(map(i)) end repeat /* write slur to longslur(.) x2 = x2 - x1 /* x range j = 0 if smode < 3 loop for i = y1 to y2 map(i) = map(i) // pad(MAPZ) out = map(i){x1,x2} if smode = 2 out = rev(out) end out = trm(out) if out = "" and (i = y1 or i = y2) else ++j temp = pak(out) longslur(j) = cby(temp) end repeat else loop for i = y2 to y1 step -1 map(i) = map(i) // pad(MAPZ) out = map(i){x1,x2} if smode = 3 out = rev(out) end out = trm(out) if out = "" and (i = y1 or i = y2) else ++j temp = pak(out) longslur(j) = cby(temp) end repeat end if smode = 1 length = j - 1 else if smode = 2 length = j - 1 - rise else if smode = 3 length = rise else length = 0 end end end rise = j passback length,rise /* length = initial offset; rise = number of rows return #if PRINT Code added 03/05/04: In order to implement "in-line" spacing for printing we need a PRINT version of stringout. procedure stringout (out) str out.500,char.1 int font,i,k getvalue out loop for i = 1 to len(out) k = ors(out{i}) if k > 130 and k < 142 if k < 140 k -= 130 putp .b27 *p+~k X... x += (k - 130) else k -= 139 putp .b27 *p-~k X... x -= (k - 139) end else char = chr(k) putp ~char ... end repeat return #else ╔═════════════════════════════════════════════╗ ║ ║ ║ PROCEDURES ADDED FOR SCREEN DISPLAY ║ ║ ║ ╚═════════════════════════════════════════════╝ * procedure stringout (out) str out.500 int font,i,k getvalue out int scx2 /* added 11/29/09 #if POSTSCRIPT loop for i = 1 to len(out) k = ors(out{i}) if k > 130 and k < 142 if k < 140 scx += (k - 130) else scx -= (k - 139) end else scb = k perform charout end repeat #else font = revmap(scf) font = font - 1 * 256 loop for i = 1 to len(out) Code substitution 03/05/04: To implement "in-line" spacing for display k = ors(out{i}) if k > 130 and k < 142 if k < 140 scx += (k - 130) else scx -= (k - 139) end else k += font New 11/29/09 This variation includes the "scrolling" for dscroll #if DSCROLL if stationary = 1 setb gstr,FA,scx,scy,k,1 else if h_shift = 0 setb gstr,FA,scx,scy,k,1 else scx2 = scx - h_shift if scx2 > 500 setb gstr,FA,scx2,scy,k,1 scx = scx2 + h_shift end end end #else setb gstr,FA,scx,scy,k,1 #endif End of 11/29/09 addition end End of 03/05/04 addition k = ors(out{i}) + font setb gstr,FA,scx,scy,k,1 repeat #endif return procedure charout int font,k font = revmap(scf) int scx2 #if POSTSCRIPT ++ct_cnt tput [CT,ct_cnt] Calling charout: font = ~font loc = <~scx ,~scy > char = ~scb ++glyph_record(font,scb) ++moveto_count #endif putc scb= ~scb font = ~font scf = ~scf /* DEBUG font = font - 1 * 256 k = scb + font putc k = ~k font = ~font /* DEBUG New 11/29/09 This variation includes the "scrolling" for dscroll #if DSCROLL if h_shift = 0 setb gstr,FA,scx,scy,k,1 else scx2 = scx - h_shift if scx2 > 500 setb gstr,FA,scx2,scy,k,1 scx = scx2 + h_shift else if scb = 81 and scx2 > 400 scx = scx2 + h_shift if scx2 < 470 scx2 = 470 end setb gstr,FA,scx2,scy,k,1 end end end #else setb gstr,FA,scx,scy,k,1 #endif End of 11/29/09 addition return procedure pan (flag) int k,h,j int x(5),y(5) /* New sizes 03/12/05 int flag int sflag,oldsflag int wflag2,wflag3,wflag4 int wflag5,sflag_fact /* New variables 03/12/05 int px,py int save_sflag /* added 11/29/09 int save_oldsflag /* added 11/29/09 flag = 0 wflag2 = 0 wflag3 = 0 wflag4 = 0 wflag5 = 0 /* New 03/12/05 New 11/29/09 The dscroll code retains certain variables for re-entry to pan (i), following an exit to redraw after a "shift." #if DSCROLL if save_sflag = 0 sflag = 1 oldsflag = 1 x(1) = 20 y(1) = 240 x(2) = 10 y(2) = 160 x(3) = 20 y(3) = 160 x(4) = 20 y(4) = 160 x(5) = 20 /* New 03/12/05 y(5) = 240 /* New 03/12/05 else sflag = save_sflag oldsflag = save_oldsflag if sflag = 2 dscale2 gstr, tstr2 wflag2 = 1 end if sflag = 3 dscale3 gstr, tstr3 wflag3 = 1 end if sflag = 4 dscale2 gstr, tstr2 wflag2 = 1 dscale2 tstr2, tstr4 wflag4 = 1 end if sflag = 5 dscale5 gstr, tstr5 wflag5 = 1 end end #else sflag = 1 oldsflag = 1 x(1) = 20 y(1) = 240 x(2) = 10 y(2) = 160 x(3) = 20 y(3) = 160 x(4) = 20 y(4) = 160 x(5) = 20 /* New 03/12/05 y(5) = 240 /* New 03/12/05 #endif End of 11/29/09 addition PPP: if oldsflag > 0 px = x(oldsflag) py = y(oldsflag) end if oldsflag <> sflag if oldsflag = 1 #if DSCROLL #else activate gstr,px,py,5 /* Only dskpage needs this. #endif activate blue_horiz1t,px-10-LMRG1,py-TMRG1,5 activate blue_horiz1b,px-10-LMRG1,py+3300-TMRG1,5 activate blue_vert1v,px-LMRG1,py-80-TMRG1,5 activate blue_vert1r,px+319-LMRG1,py-80-TMRG1,5 else if oldsflag = 2 #if DSCROLL #else activate tstr2,px,py,5 /* Only dskpage needs this. #endif activate blue_horiz2t,px-10-LMRG2,py-TMRG2,5 activate blue_horiz2b,px-10-LMRG2,py+1650-TMRG2,5 activate blue_vert2v,px-LMRG2,py-80-TMRG2,5 activate blue_vert2r,px+159-LMRG2,py-80-TMRG2,5 else if oldsflag = 3 #if DSCROLL #else activate tstr3,px,py,5 /* Only dskpage needs this. #endif activate blue_horiz3t,px-10-LMRG3,py-TMRG3,5 activate blue_horiz3b,px-10-LMRG3,py+1100-TMRG3,5 activate blue_vert3v,px-LMRG3,py-80-TMRG3,5 activate blue_vert3r,px+106-LMRG3,py-80-TMRG3,5 else if oldsflag = 4 #if DSCROLL #else activate tstr4,px,py,5 /* Only dskpage needs this. #endif activate blue_horiz4t,px-10-LMRG4,py-TMRG4,5 activate blue_horiz4b,px-10-LMRG4,py+825-TMRG4,5 activate blue_vert4v,px-LMRG4,py-80-TMRG4,5 activate blue_vert4r,px+79-LMRG4,py-80-TMRG4,5 else /* New 03/12/05 #if DSCROLL #else activate tstr5,px,py,5 /* Only dskpage needs this. #endif activate blue_horiz5t,px-10-LMRG5,py-TMRG5,5 activate blue_horiz5b,px-10-LMRG5,py+2200-TMRG5,5 activate blue_vert5v,px-LMRG5,py-80-TMRG5,5 activate blue_vert5r,px+210-LMRG5,py-80-TMRG5,5 end end end end end oldsflag = sflag px = x(sflag) py = y(sflag) if sflag = 1 activate gstr,px,py,1 activate blue_horiz1t,px-10-LMRG1,py-TMRG1,3 activate blue_horiz1b,px-10-LMRG1,py+3300-TMRG1,3 activate blue_vert1v,px-LMRG1,py-80-TMRG1,3 activate blue_vert1r,px+319-LMRG1,py-80-TMRG1,3 else if sflag = 2 activate tstr2,px,py,1 activate blue_horiz2t,px-10-LMRG2,py-TMRG2,3 activate blue_horiz2b,px-10-LMRG2,py+1650-TMRG2,3 activate blue_vert2v,px-LMRG2,py-80-TMRG2,3 activate blue_vert2r,px+159-LMRG2,py-80-TMRG2,3 else if sflag = 3 activate tstr3,px,py,1 activate blue_horiz3t,px-10-LMRG3,py-TMRG3,3 activate blue_horiz3b,px-10-LMRG3,py+1100-TMRG3,3 activate blue_vert3v,px-LMRG3,py-80-TMRG3,3 activate blue_vert3r,px+106-LMRG3,py-80-TMRG3,3 else if sflag = 4 activate tstr4,px,py,1 activate blue_horiz4t,px-10-LMRG4,py-TMRG4,3 activate blue_horiz4b,px-10-LMRG4,py+825-TMRG4,3 activate blue_vert4v,px-LMRG4,py-80-TMRG4,3 activate blue_vert4r,px+79-LMRG4,py-80-TMRG4,3 else /* New 03/12/05 activate tstr5,px,py,1 activate blue_horiz5t,px-10-LMRG5,py-TMRG5,3 activate blue_horiz5b,px-10-LMRG5,py+2200-TMRG5,3 activate blue_vert5v,px-LMRG5,py-80-TMRG5,3 activate blue_vert5r,px+210-LMRG5,py-80-TMRG5,3 end end end end getk k Display Commands if k = 0x03040a /* <Backspace> activate gstr,0,0,0 activate blue_horiz1t,0,0,0 activate blue_horiz1b,0,0,0 activate blue_vert1v,0,0,0 activate blue_vert1r,0,0,0 flag = 1 sflag = 1 oldsflag = 0 wflag2 = 0 wflag3 = 0 wflag4 = 0 passback flag return end if k = 0x030810 /* <Tab> activate gstr,0,0,0 activate blue_horiz1t,0,0,0 activate blue_horiz1b,0,0,0 activate blue_vert1v,0,0,0 activate blue_vert1r,0,0,0 flag = 2 sflag = 1 oldsflag = 0 wflag2 = 0 wflag3 = 0 wflag4 = 0 passback flag return end if k = 0x03080c /* <Enter> activate gstr,0,0,0 activate blue_horiz1t,0,0,0 activate blue_horiz1b,0,0,0 activate blue_vert1v,0,0,0 activate blue_vert1r,0,0,0 sflag = 1 oldsflag = 0 wflag2 = 0 wflag3 = 0 wflag4 = 0 passback flag return end if k = 0x01001b /* <esc> putc .b27 Y.b27 F... stop end /* New variable 03/12/05 sflag_fact = sflag if sflag = 5 sflag_fact = 1 end if k = 0x030101 /* ← if x(sflag) < 40 x(sflag) += hpar(58) / 3 / sflag_fact end end if k = 0x030103 /* → if x(sflag) > xze - 340 x(sflag) -= hpar(58) / 3 / sflag_fact end end if k = 0x030104 /* ↓ if y(sflag) > yze - 3500 y(sflag) -= vpar(43) / 3 / sflag_fact end end if k = 0x030102 /* ↑ if y(sflag) < 320 y(sflag) += vpar(43) / 3 / sflag_fact end end if k = 0x030105 /* shft ← if x(sflag) < 40 x(sflag) += hpar(58) / sflag_fact end end if k = 0x030107 /* shft → if x(sflag) > xze - 340 x(sflag) -= hpar(58) / sflag_fact end end if k = 0x030108 /* shft ↓ if y(sflag) > yze - 3500 y(sflag) -= vpar(43) / sflag_fact end end if k = 0x030106 /* shft ↑ if y(sflag) < 320 y(sflag) += vpar(43) / sflag_fact end end New 11/29/09 New commands for dscroll #if DSCROLL if k = 0x03010d /* alt ← if h_shift > 499 h_shift -= 500 goto RECON end end if k = 0x03010f /* alt → h_shift += 500 goto RECON end if k = 0x030111 /* shft-alt ← if h_shift > 4999 h_shift -= 5000 goto RECON end end if k = 0x030112 /* shft-alt → h_shift += 5000 goto RECON end #endif End of 11/29/09 addition if k = 0x010032 /* 2 if sflag <> 2 sflag = 2 if wflag2 = 0 dscale2 gstr, tstr2 wflag2 = 1 end end end if k = 0x010033 /* 3 if sflag <> 3 sflag = 3 if wflag3 = 0 dscale3 gstr, tstr3 wflag3 = 1 end end end if k = 0x010034 /* 4 if sflag <> 4 sflag = 4 if wflag2 = 0 dscale2 gstr, tstr2 wflag2 = 1 end if wflag4 = 0 dscale2 tstr2, tstr4 wflag4 = 1 end end end if k = 0x010035 /* 5 New 03/12/05 if sflag <> 5 sflag = 5 if wflag5 = 0 dscale5 gstr, tstr5 wflag5 = 1 end end end if k = 0x010031 /* 1 if sflag <> 1 sflag = 1 end end goto PPP RECON: New 11/29/09 dscroll required different return conditions after "scrolling." #if DSCROLL activate blue_horiz1t,0,0,0 activate blue_horiz1b,0,0,0 activate blue_vert1v,0,0,0 activate blue_vert1r,0,0,0 flag = 3 save_sflag = sflag save_oldsflag = oldsflag wflag2 = 0 wflag3 = 0 wflag4 = 0 passback flag #endif End of 11/29/09 addition return #endif end of the "else" part of if PRINT (i.e., if not-PRINT) *P XX. init_par Purpose: Initialize Vertical and Horizontal Parameters also expar(.) parameters Inputs: notesize Outputs: vpar(.) hpar(.) vpar20 expar(.) revmap(.) sizenum Other operations: In all cases, if scf = old notesize, then scf reset to new notesize In the case of PRINT, changes the active font to match the new size. procedure init_par int pz /* added 03/15/04 int a,b,i bstr cycle.200 03/15/04 Changing sizenum to range from 1 to 12 sizenum = revsizes(notesize) /* New 02/19/06 if notesize = 6 sizenum = 3 end if notesize = 14 sizenum = 8 end if notesize = 21 sizenum = 11 end if notesize = 18 /* New size-18 12/18/04 sizenum = 10 end if notesize = 14 sizenum = 1 end if notesize = 21 sizenum = 2 end if notesize = 6 sizenum = 3 end Vertical parameters ─────────────────── if notesize = 14 vpar(13) = 8 vpar(42) = 4 vpar(43) = 240 vpar(44) = 1 end if notesize = 6 vpar(13) = 3 /* Changed from 4 to 3 01/30/05 vpar(42) = 2 vpar(43) = 80 vpar(44) = 1 end if notesize = 21 vpar(13) = 12 vpar(42) = 6 vpar(43) = 240 vpar(44) = 3 end if notesize = 18 /* New size-18 12/18/04 vpar(13) = 10 vpar(42) = 5 vpar(43) = 240 vpar(44) = 2 end if notesize = 16 /* New size-16 12/31/08 vpar(13) = 9 vpar(42) = 4 vpar(43) = 240 vpar(44) = 1 end loop for i = 1 to 10 vpar(i) = notesize * i / 2 repeat vpar(11) = 200 * notesize / 16 vpar(12) = 4 * notesize / 16 vpar(14) = 160 * notesize / 16 vpar(15) = 64 * notesize / 16 vpar(16) = 3 * notesize vpar(17) = notesize / 2 vpar(18) = 30 * notesize / 16 vpar(19) = 15 vpar(20) = notesize + 3 / 4 vpar(21) = notesize - vpar(20) vpar(22) = 6 * notesize / 16 vpar(23) = 9 * notesize / 16 vpar(24) = 7 * notesize / 16 vpar(25) = 22 * notesize / 16 vpar(26) = 27 * notesize / 16 vpar(27) = 72 * notesize / 16 vpar(28) = 15 * notesize / 16 vpar(29) = 38 * notesize / 16 vpar(30) = 3 * notesize - 8 / 16 vpar(31) = notesize / 2 + 1 vpar(32) = notesize * 8 + 4 / 10 vpar(33) = notesize * 12 + 10 / 14 vpar(34) = notesize - 3 / 9 vpar(35) = notesize / 3 vpar(36) = 7 * notesize vpar(37) = 5 * notesize / 4 vpar(38) = 4 * notesize / 3 vpar(39) = notesize vpar(40) = 3 * notesize / 5 vpar(41) = vpar(5) vpar(45) = 2 * notesize vpar20 = notesize * 10 Horizontal parameters ───────────────────── if notesize = 14 hpar(2) = 15 hpar(3) = 19 hpar(5) = 13 hpar(6) = 80 hpar(7) = 56 /* 01/20/05 made explicit hpar(12) = 80 hpar(17) = 14 hpar(19) = 4 hpar(20) = 20 hpar(29) = 2 hpar(30) = 17 hpar(33) = 6 hpar(34) = 7 hpar(43) = 40 hpar(48) = 8 hpar(58) = 30 hpar(60) = 254 hpar(61) = 20 hpar(62) = 2 hpar(63) = 90 end if notesize = 6 hpar(2) = 7 hpar(3) = 8 hpar(5) = 6 hpar(6) = 34 hpar(7) = 18 /* 01/20/05 changed from 24 to 18 and made explicit hpar(12) = 35 hpar(17) = 7 hpar(19) = 2 hpar(20) = 9 hpar(29) = 1 hpar(30) = 8 hpar(33) = 3 hpar(34) = 4 hpar(43) = 30 hpar(48) = 4 hpar(58) = 10 hpar(60) = 110 hpar(61) = 10 hpar(62) = 1 hpar(63) = 90 end if notesize = 21 hpar(2) = 19 hpar(3) = 28 hpar(5) = 18 /* 12/18/04 changed from 19 to 18 hpar(6) = 110 hpar(7) = 88 /* 01/20/05 made explicit hpar(12) = 100 hpar(17) = 21 hpar(19) = 6 hpar(20) = 30 hpar(29) = 3 hpar(30) = 22 hpar(33) = 8 /* 12/18/04 changed from 9 to 8 hpar(34) = 11 hpar(43) = 30 hpar(48) = 13 hpar(58) = 30 hpar(60) = 381 hpar(61) = 30 hpar(62) = 3 hpar(63) = 80 end New 12/31/08 notesize 16 parameters added if notesize = 16 hpar(2) = 16 hpar(3) = 22 hpar(5) = 15 hpar(6) = 90 hpar(7) = 64 hpar(12) = 80 hpar(17) = 16 hpar(19) = 4 hpar(20) = 23 hpar(29) = 2 hpar(30) = 18 hpar(33) = 6 hpar(34) = 9 hpar(43) = 30 hpar(48) = 9 hpar(58) = 30 hpar(60) = 280 hpar(61) = 22 hpar(62) = 2 hpar(63) = 80 #if BIG16 ++hpar(3) #endif end New 12/18/04 notesize 18 parameters added if notesize = 18 hpar(2) = 17 hpar(3) = 26 hpar(5) = 17 hpar(6) = 100 hpar(7) = 72 /* 01/20/05 made explicit hpar(12) = 90 hpar(17) = 18 hpar(19) = 5 hpar(20) = 26 hpar(29) = 3 hpar(30) = 20 hpar(33) = 7 hpar(34) = 9 hpar(43) = 30 hpar(48) = 10 hpar(58) = 30 hpar(60) = 326 hpar(61) = 26 hpar(62) = 2 hpar(63) = 80 end hpar(1) = 30 hpar(2) = 18 * notesize / 16 hpar(3) = 19 * notesize + 8 / 16 hpar(4) = 3 hpar(5) = 13 * notesize + 2 / 16 hpar(6) = 80 hpar(7) = 4 * notesize /* 01/20/05 made explicit hpar(8) = 200 hpar(9) = 2250 hpar(10) = 26 * notesize / 16 hpar(11) = 200 * notesize / 16 hpar(12) = 80 hpar(14) = 40 * notesize / 16 hpar(16) = 24 * notesize / 16 hpar(17) = 14 hpar(18) = 2 * notesize hpar(19) = 4 hpar(20) = 20 hpar(21) = 300 hpar(22) = 6 * notesize / 16 (not used) hpar(23) = 60 * notesize / 16 (not used) hpar(24) = 7 * notesize + 2 / 7 (not used) hpar(25) = notesize + 1 (not used) hpar(26) = 15 * notesize / 16 (not used) hpar(27) = 0 (not used) hpar(28) = 0 - 32 * notesize / 16 (not used) hpar(29) = 2 * notesize + 8 / 16 hpar(30) += hpar(29) hpar(31) = 24 * notesize / 16 hpar(32) = 44 * notesize / 16 hpar(33) = 6 * notesize / 16 hpar(34) = 8 * notesize / 16 hpar(35) = 14 * notesize / 16 hpar(36) = 8 * notesize / 16 hpar(37) = 20 * notesize / 16 hpar(38) = 20 * notesize / 16 hpar(39) = 50 * notesize / 16 hpar(40) = 15 * notesize + 4 / 16 hpar(41) = vpar(5) hpar(42) = notesize * 4 hpar(43) = 40 hpar(44) = notesize hpar(45) = notesize hpar(46) = 13 * notesize / 16 hpar(47) = 2 * notesize / 5 hpar(48) = 10 * notesize / 16 hpar(49) = 24 * notesize / 16 hpar(50) = 12 * notesize / 16 hpar(51) = 31 * notesize / 16 hpar(52) = 19 * notesize / 16 hpar(53) = 4 * notesize / 16 hpar(54) = 18 * notesize / 16 hpar(55) = 6 * notesize / 16 hpar(56) = 12 * notesize / 16 hpar(57) = 2 * notesize hpar(59) = 3 * notesize / 5 New 12/31/08 parameters added for notesize 16 if notesize = 16 hpar(42) = 56 end New 12/18/04 parameters added for notesize 18 if notesize = 18 hpar(11) = 225 hpar(39) = 50 hpar(42) = 67 end if notesize = 21 hpar(11) = 250 hpar(39) = 50 hpar(42) = 76 end Other parameters and variables ────────────────────────────── if notesize = 14 expar(1) = 240 expar(2) = 324 expar(3) = 254 expar(4) = 324 expar(5) = 256 expar(6) = 324 expar(7) = 260 expar(8) = 324 end if notesize = 6 expar(1) = 102 expar(2) = 139 expar(3) = 106 expar(4) = 146 expar(5) = 107 expar(6) = 144 expar(7) = 109 expar(8) = 148 end if notesize = 21 expar(1) = 360 expar(2) = 486 expar(3) = 381 expar(4) = 498 expar(5) = 386 expar(6) = 486 expar(7) = 390 expar(8) = 498 end notesize 16 added 12/31/08 if notesize = 16 expar(1) = 278 expar(2) = 362 expar(3) = 290 expar(4) = 372 expar(5) = 296 expar(6) = 368 expar(7) = 298 expar(8) = 376 end notesize 18 added 12/18/04 if notesize = 18 expar(1) = 308 expar(2) = 424 expar(3) = 326 expar(4) = 428 expar(5) = 330 expar(6) = 422 expar(7) = 334 expar(8) = 432 end loop for i = 1 to 223 pos(i) = urpos(i) * notesize repeat Dotted mask (modified 10/23/03) OK gapsize = 3 * notesize / 4 cycle = dup("1",gapsize) // dup("0",gapsize) if notesize = 14 gapsize = 5 cycle = dup("1",7) // dup("0",3) end if notesize = 6 gapsize = 3 cycle = dup("1",4) // dup("0",2) end if notesize = 21 gapsize = 12 cycle = dup("1",15) // dup("0",9) end if notesize = 16 /* New size-16 mask 12/31/08 not OK gapsize = 9 cycle = dup("1",11) // dup("0",7) end if notesize = 18 /* New size-18 mask 12/18/04 OK gapsize = 10 cycle = dup("1",12) // dup("0",8) end dotted = "" i = 2500 - (2 * gapsize) loop dotted = dotted // cycle repeat while len(dotted) < i #if PRINT scf can be (1) old notesize (4 to 24) (requires change in scf) (2) beamfont (101 to 114) (independent of notesize) (3) text font (31 to 48) (actual font depends on notesize) (4) 300 (ties) " (5) 320 (brackets) " (6) 400 (wedges) " (7) 30 (variable pitch screen fonts, display only) (8) 200 (fixed pitch screen font, display only) if scf > 0 and (scf < 101 or scf > 114) if scf > 3 and scf < 25 scf = notesize pz = revsizes(notesize) else if scf > 30 and scf < 49 pz = revsizes(notesize) pz = XFonts(pz,scf-29) else if scf = 300 pz = revsizes(notesize) + TIE_OFFSET else if scf = 320 if notesize < 10 pz = SMALL_BRACK else pz = LARGE_BRACK end else if scf = 400 pz = wedgefont(notesize) end end end end end putp .b27 (~pz X... end #else scf can be (1) old notesize (4 to 24) (requires change in scf) (2) beamfont (101 to 114) (independent of notesize) (3) text font (31 to 48) (actual font depends on notesize) (4) 300 (ties) " (5) 320 (brackets) " (6) 400 (wedges) " (7) 30 (variable pitch screen fonts, display only) (8) 200 (fixed pitch screen font, display only) if scf > 0 and scf < 25 scf = notesize end loop for a = 1 to 24 revmap(a) = revsizes(a) repeat loop for a = 1 to 12 DONE AT THE TOP revmap(100+a) = a + BEAM_OFFSET repeat revmap(114) = 13 + BEAM_OFFSET #endif pz = revsizes(notesize) loop for a = 30 to 48 revmap(a) = XFonts(pz,a-29) repeat revmap(200) = scfont(notesize) revmap(300) = pz + TIE_OFFSET if notesize < 10 revmap(320) = SMALL_BRACK else revmap(320) = LARGE_BRACK end revmap(400) = wedgefont(notesize) return #if POSTSCRIPT *P XXI. move_to_loc (h,k) Purpose: construct a Postscript moveto entry from PCL coordinates Input: h x location k y location Output string mtloc procedure move_to_loc (h,k) int a,b,c,d,e int h,k getvalue h,k h += 50 /* magic number a = h * 10 * 24 /* in thousands of Postscript units c = 3150 - k /* also a magic number b = c * 10 * 24 mtloc = "" d = a / 1000 c = rem if d > 0 mtloc = mtloc // chs(d) // "." if c < 100 mtloc = mtloc // "0" end if c < 10 mtloc = mtloc // "0" end mtloc = mtloc // chs(c) else mtloc = mtloc // "." if a < 100 mtloc = mtloc // "0" end if a < 10 mtloc = mtloc // "0" end mtloc = mtloc // chs(a) end mtloc = mtloc // " " d = b / 1000 c = rem if d > 0 mtloc = mtloc // chs(d) // "." if c < 100 mtloc = mtloc // "0" end if c < 10 mtloc = mtloc // "0" end mtloc = mtloc // chs(c) else mtloc = mtloc // "." if b < 100 mtloc = mtloc // "0" end if b < 10 mtloc = mtloc // "0" end mtloc = mtloc // chs(b) end mtloc = mtloc // " moveto" return *P XXII. compute_delta_move (lastx, lasty, h, k) Purpose: construct a Postscript delta move entry from PCL coordinates Input: lastx former x location lasty former y location h current x location k current y location Output string mtloc procedure compute_delta_move (lastx, lasty, h, k) int a,b,c,d,e int h,k,lastx,lasty getvalue lastx,lasty,h,k h = h - lastx k = lasty - k mtloc = "" if h < 0 h = 0 - h mtloc = mtloc // "-" end a = h * 10 * 24 /* in thousands of Postscript units if a = 0 mtloc = mtloc // "0" else d = a / 1000 c = rem if d > 0 mtloc = mtloc // chs(d) // "." if c < 100 mtloc = mtloc // "0" end if c < 10 mtloc = mtloc // "0" end mtloc = mtloc // chs(c) else mtloc = mtloc // "0." if a < 100 mtloc = mtloc // "0" end if a < 10 mtloc = mtloc // "0" end mtloc = mtloc // chs(a) end end mtloc = mtloc // " " if k < 0 k = 0 - k mtloc = mtloc // "-" end b = k * 10 * 24 /* in thousands of Postscript units if b = 0 mtloc = mtloc // "0" else d = b / 1000 c = rem if d > 0 mtloc = mtloc // chs(d) // "." if c < 100 mtloc = mtloc // "0" end if c < 10 mtloc = mtloc // "0" end mtloc = mtloc // chs(c) else mtloc = mtloc // "0." if b < 100 mtloc = mtloc // "0" end if b < 10 mtloc = mtloc // "0" end mtloc = mtloc // chs(b) end end return *P XXIII. build_page_pdict Purpose: construct a customized Postscript dictionary for a page Input: list of fonts and glyphs in table Z Output custormized Postscript dictionary in table PD procedure build_page_pdict str data.100 str temp.10000 int f,g,h int i,j,k int font,glyph int t1,t2,t3,t4,t5,t6,t7,t8 int a(16) int glyph_loc(256) int gcount int glyphs(256) int font_loc int width,width2 /* New 03/08/09 int height /* New 03/08/09 real x /* New 03/08/09 str glyph_xmap.100(100) /* New 03/08/09 str s1.100,s2.100,s3.100 /* New 03/08/09 int xoff,yoff /* New 03/08/09 bstr tbstr.100 /* New 03/08/09 pd_cnt = 0 zpnt = 1 BPD_A: tget [Z,zpnt] data .t6 font .t9 glyph if data{1} = "$" goto BPD_END end if data{1} = "f" putc ++pd_cnt tput [PD,pd_cnt] putc Working on font ~font tget [XX,font] t1 putc ++pd_cnt tput [PD,pd_cnt] putc Looking in location ~t1 font_loc = t1 k = 0 loop for i = 1 to 16 tget [XX,t1] a(1) a(2) a(3) a(4) a(5) a(6) a(7) a(8) a(9) a(10) a(11) a(12) a(13) a(14) a(15) a(16) ++t1 loop for j = 1 to 16 ++k glyph_loc(k) = a(j) repeat repeat loop for i = 1 to 7 tget [XX,t1] data ++t1 putc ~data ++pd_cnt tput [PD,pd_cnt] ~data repeat zpnt2 = zpnt + 2 gcount = 1 BPD_B: tget [Z,zpnt2] data .t9 glyph tget [Z,zpnt2+1] temp temp = temp // pad(4) glyphs(gcount) = glyph ++gcount if data{4} = "c" and temp{4} = "c" putc dup ~glyph /mus_~glyph put ++pd_cnt tput [PD,pd_cnt] dup ~glyph /mus_~glyph put ++zpnt2 goto BPD_B else putc ~glyph /mus_~glyph put ++pd_cnt tput [PD,pd_cnt] ~glyph /mus_~glyph put zpnt = zpnt2 + 1 end putc putc /BuildChar putc {0 begin putc /char exch def putc /fontdict exch def putc /charname fontdict /Encoding get char get def putc putc /charinfo fontdict /CharData get charname get def putc putc /wx charinfo 0 get def putc /charbbox charinfo 1 4 getinterval def putc wx 0 charbbox aload pop setcachedevice putc putc charinfo 5 get charinfo 6 get true putc putc fontdict /imagemaskmatrix get putc dup 4 charinfo 7 get put putc dup 5 charinfo 8 get put putc charinfo 9 1 getinterval cvx putc imagemask putc end putc } def putc putc /BuildChar load 0 6 dict put putc ++pd_cnt tput [PD,pd_cnt] ++pd_cnt tput [PD,pd_cnt] /BuildChar ++pd_cnt tput [PD,pd_cnt] {0 begin ++pd_cnt tput [PD,pd_cnt] /char exch def ++pd_cnt tput [PD,pd_cnt] /fontdict exch def ++pd_cnt tput [PD,pd_cnt] /charname fontdict /Encoding get char get def ++pd_cnt tput [PD,pd_cnt] ++pd_cnt tput [PD,pd_cnt] /charinfo fontdict /CharData get charname get def ++pd_cnt tput [PD,pd_cnt] ++pd_cnt tput [PD,pd_cnt] /wx charinfo 0 get def ++pd_cnt tput [PD,pd_cnt] /charbbox charinfo 1 4 getinterval def ++pd_cnt tput [PD,pd_cnt] wx 0 charbbox aload pop setcachedevice ++pd_cnt tput [PD,pd_cnt] ++pd_cnt tput [PD,pd_cnt] charinfo 5 get charinfo 6 get true ++pd_cnt tput [PD,pd_cnt] ++pd_cnt tput [PD,pd_cnt] fontdict /imagemaskmatrix get ++pd_cnt tput [PD,pd_cnt] dup 4 charinfo 7 get put ++pd_cnt tput [PD,pd_cnt] dup 5 charinfo 8 get put ++pd_cnt tput [PD,pd_cnt] charinfo 9 1 getinterval cvx ++pd_cnt tput [PD,pd_cnt] imagemask ++pd_cnt tput [PD,pd_cnt] end ++pd_cnt tput [PD,pd_cnt] } def ++pd_cnt tput [PD,pd_cnt] ++pd_cnt tput [PD,pd_cnt] /BuildChar load 0 6 dict put ++pd_cnt tput [PD,pd_cnt] tget [XX,t1] data ++t1 /* imagemask putc ~data ++pd_cnt tput [PD,pd_cnt] ~data tget [XX,t1] data ++t1 /* /CharData xxx dict def putc /CharData ~gcount dict def putc CharData begin ++pd_cnt tput [PD,pd_cnt] /CharData ~gcount dict def ++pd_cnt tput [PD,pd_cnt] CharData begin loop for i = 1 to gcount - 1 j = glyphs(i) k = glyph_loc(j) + font_loc tget [XX,k] data .t8 h if h <> j dputc Logic Error dputc ~h ~j stop end putc ~data ++pd_cnt tput [PD,pd_cnt] ~data New code 03/08/09 to implement matrix code implantation in the treble clef (notesizes 12 and above) and bass clef (notesizes 16 and above). glyph = j if chr(font) in [7..11] and chr(glyph) in [34,36] if glyph = 36 and font < 9 goto ORDINARY end Get width and height from data string e.g. data = " /mus_34 [.00 .06 -.37 .63 .40 57 77 -6.5 40.0 <" if data con "[" data = data{mpt+1..} end tput [NC,1] ~data tget [NC,1] x x x x x width height dputc width = ~width dputc height = ~height width2 = width + 7 / 8 * 8 t2 = width2 >> 2 This loop is where the glyph definition for a particular font is normally transferred from the postdict master dictionary to the page dictionary. Note that a non-hex record is also read here. temp = "" loop ++k tget [XX,k] data data = trm(data) if data{1} <> ">" temp = temp // data end repeat while data{1} <> ">" t8 = len(temp) Convert the temp string to an x's bit map t4 = 0 loop for t3 = 1 to len(temp) step t2 data = temp{t3,t2} s1 = "" loop for t5 = 1 to t2 if "0123456789ABCDEF" con data{t5} s1 = s1 // xhex(mpt) end repeat ++t4 glyph_xmap(t4) = s1 dputc ~s1 repeat if t4 <> height putc Error in Program logic (reading postdict) stop end Now you can insert the code matrix into the glyph if glyph = 34 xoff = matrix_offset(font,1) yoff = matrix_offset(font,2) else xoff = matrix_offset(font,3) yoff = matrix_offset(font,4) end t6 = yoff loop for t5 = 1 to 8 ++t6 glyph_xmap(t6){xoff+1,9} = grid(t5) repeat dputc Now the glyph looks like this loop for t5 = 1 to height dputc ~glyph_xmap(t5) repeat Now reconstruct the temp string and spool it out to the postscript dictionary temp = "" loop for t5 = 1 to height s1 = glyph_xmap(t5) tbstr = pak(s1) s1 = cby(tbstr) s2 = "" loop for t6 = 1 to len(s1) t7 = ors(s1{t6}) if t7 < 16 s2 = s2 // "0" // hex(t7) else s2 = s2 // hex(t7) end repeat s2 = ucs(s2) s2 = s2 // "00000000" s2 = s2{1,t2} temp = temp // s2 repeat if len(temp) <> t8 putc Logic Error in inserting code matrix putc Reconstructed temp is the wrong length stop end loop for t5 = 1 to t8 step 80 if t5 < t8 - 79 /* suppose t5 = 1 and length = 81 data = temp{t5,80} else data = temp{t5..} end ++pd_cnt tput [PD,pd_cnt] ~data repeat Don't forget to append the closing of the definition. This was read from the proto-dictionary and discarded above. ++pd_cnt tput [PD,pd_cnt] > ] def goto SKIP_ORDINARY end End of new code 03/08/09 to implement matrix code implantation in the This loop is where the glyph definition for a particular font is transferred from the postdict master dictionary to the page dictionary. ORDINARY: loop ++k tget [XX,k] data putc ~data ++pd_cnt tput [PD,pd_cnt] ~data repeat while data{1} <> ">" SKIP_ORDINARY: repeat k = glyph_loc(256) + font_loc loop for i = 1 to 5 tget [XX,k] data ++k putc ~data ++pd_cnt tput [PD,pd_cnt] ~data repeat goto BPD_A end BPD_END: putc putc Done, I think return *P XXIV. build_regular_slur_dict (n,t1,t2,t3,t4,t5) Purpose: construct a customized Postscript dictionary for regular slurs on a page Inputs: table ST contains data for regular slurs int n number of slurs in dictionary int t1 table pointer to first entry int t2 table pointer to last data entry int t3 maximum height for all slurs int t4 maximum width for all slurs int t5 dictionary number (1 or 2, at the moment) int pt_cnt2 pointer to next available location in auxillary PostScript output table int sd_cnt pointer to next available location in the slur dictionary Output: table SD custormized Postscript dictionaries of slurs int pt_cnt2 pointer to next available location in auxillary PostScript output table int sd_cnt pointer to next available location in the slur dictionary procedure build_regular_slur_dict (n, t1, t2, t3, t4, t5) str data.100 str temp.1000 int f,g,h int i,j,k int n int font,glyph int t1,t2,t3,t4,t5 int a1,a2,a3,a4,a5,a6,a7,a8 int hh,kk getvalue n,t1,t2,t3,t4,t5 t4 = t4 + 7 / 8 * 8 /* allign maximum width /* on byte boundary Start up the auxiliary PostScript output table a6 = t5 + 2000 ++pt_cnt2 tput [PT2,pt_cnt2] /Bitfont~a6 findfont 24 scalefont setfont putc ++sd_cnt tput [SD,sd_cnt] putc 9 dict dup begin ++sd_cnt tput [SD,sd_cnt] 9 dict dup begin putc /FontType 3 def ++sd_cnt tput [SD,sd_cnt] /FontType 3 def putc /FontMatrix [1 0 0 1 0 0] def ++sd_cnt tput [SD,sd_cnt] /FontMatrix [1 0 0 1 0 0] def Construct coordinates for font bounding box temp = "" a1 = t4 / 100 a2 = rem temp = temp // chs(a1) // "." if a2 < 10 temp = temp // "0" end temp = temp // chs(a2) // " " a1 = t3 / 100 a2 = rem temp = temp // chs(a1) // "." if a2 < 10 temp = temp // "0" end temp = temp // chs(a2) // " 0 0" putc /FontBBox [~temp ] def ++sd_cnt tput [SD,sd_cnt] /FontBBox [~temp ] def putc ++sd_cnt tput [SD,sd_cnt] putc /Encoding 256 array def ++sd_cnt tput [SD,sd_cnt] /Encoding 256 array def putc 0 1 255 {Encoding exch /.b46 notdef put} for ++sd_cnt tput [SD,sd_cnt] 0 1 255 {Encoding exch /.b46 notdef put} for putc Encoding ++sd_cnt tput [SD,sd_cnt] Encoding a2 = 32 loop for a1 = 1 to n if a1 = n putc ~a2 /mus_~a2 put ++sd_cnt tput [SD,sd_cnt] ~a2 /mus_~a2 put else putc dup ~a2 /mus_~a2 put ++sd_cnt tput [SD,sd_cnt] dup ~a2 /mus_~a2 put end ++a2 if a2 = 128 a2 = 160 end repeat putc putc /BuildChar putc {0 begin putc /char exch def putc /fontdict exch def putc /charname fontdict /Encoding get char get def putc putc /charinfo fontdict /CharData get charname get def putc putc /wx charinfo 0 get def putc /charbbox charinfo 1 4 getinterval def putc wx 0 charbbox aload pop setcachedevice putc putc charinfo 5 get charinfo 6 get true putc putc fontdict /imagemaskmatrix get putc dup 4 charinfo 7 get put putc dup 5 charinfo 8 get put putc charinfo 9 1 getinterval cvx putc imagemask putc end putc } def putc putc /BuildChar load 0 6 dict put putc ++sd_cnt tput [SD,sd_cnt] ++sd_cnt tput [SD,sd_cnt] /BuildChar ++sd_cnt tput [SD,sd_cnt] {0 begin ++sd_cnt tput [SD,sd_cnt] /char exch def ++sd_cnt tput [SD,sd_cnt] /fontdict exch def ++sd_cnt tput [SD,sd_cnt] /charname fontdict /Encoding get char get def ++sd_cnt tput [SD,sd_cnt] ++sd_cnt tput [SD,sd_cnt] /charinfo fontdict /CharData get charname get def ++sd_cnt tput [SD,sd_cnt] ++sd_cnt tput [SD,sd_cnt] /wx charinfo 0 get def ++sd_cnt tput [SD,sd_cnt] /charbbox charinfo 1 4 getinterval def ++sd_cnt tput [SD,sd_cnt] wx 0 charbbox aload pop setcachedevice ++sd_cnt tput [SD,sd_cnt] ++sd_cnt tput [SD,sd_cnt] charinfo 5 get charinfo 6 get true ++sd_cnt tput [SD,sd_cnt] ++sd_cnt tput [SD,sd_cnt] fontdict /imagemaskmatrix get ++sd_cnt tput [SD,sd_cnt] dup 4 charinfo 7 get put ++sd_cnt tput [SD,sd_cnt] dup 5 charinfo 8 get put ++sd_cnt tput [SD,sd_cnt] charinfo 9 1 getinterval cvx ++sd_cnt tput [SD,sd_cnt] imagemask ++sd_cnt tput [SD,sd_cnt] end ++sd_cnt tput [SD,sd_cnt] } def ++sd_cnt tput [SD,sd_cnt] ++sd_cnt tput [SD,sd_cnt] /BuildChar load 0 6 dict put ++sd_cnt tput [SD,sd_cnt] putc /imagemaskmatrix [100 0 0 -100 0 0] def ++sd_cnt tput [SD,sd_cnt] /imagemaskmatrix [100 0 0 -100 0 0] def putc ++sd_cnt tput [SD,sd_cnt] putc /CharData ~(n+1) dict def ++sd_cnt tput [SD,sd_cnt] /CharData ~(n+1) dict def putc CharData begin ++sd_cnt tput [SD,sd_cnt] CharData begin a1 = t1 - 1 a8 = 32 loop for a2 = 1 to n ++a1 tget [ST,a1] temp if temp{1} <> "C" dputc Error 4 ~temp stop end if temp con "slur at" a3 = mpt temp = temp{a3+9..} tput [Y,1] ~temp tget [Y,1] hh kk end ++a1 tget [ST,a1] temp if temp{1} <> ":" dputc Error 3 stop end Determine height and width of this slur a4 = 0 /* height counter a5 = 0 /* max width loop for a3 = a1+1 to t2 /* t2 is end of table tget [ST,a3] temp temp = trm(temp) temp = temp // pad(1) if temp{1} = ":" /* terminating ":" a3 = t2 /* exit loop else ++a4 /* increment height a6 = len(temp) if a6 > a5 a5 = a6 end end repeat a5 = a5 + 7 / 8 * 8 /* allign width on byte boundary With height now determined, you can now locate the slur h = hh + 50 /* magic number h = h * 10 * 24 k = 3150 - kk /* also a magic number k -= a4 /* position to bottom of image k = k + 1 /* another magic number k = k * 10 * 24 temp = oct(a8) if len(temp) < 3 temp = "0" // temp end Convert h and k to decimals (i.e., divide by 1000) data = "" a6 = h / 1000 a7 = rem data = data // chs(a6) // "." if a7 < 100 data = data // "0" end if a7 < 10 data = data // "0" end data = data // chs(a7) // " " a6 = k / 1000 a7 = rem data = data // chs(a6) // "." if a7 < 100 data = data // "0" end if a7 < 10 data = data // "0" end data = data // chs(a7) ++pt_cnt2 tput [PT2,pt_cnt2] ~data moveto (\~temp ) show Construct first 9 elements of def matrix temp = "[ 0 0 0 " a6 = a5 / 100 a7 = rem temp = temp // chs(a6) // "." if a7 < 10 temp = temp // "0" end temp = temp // chs(a7) // " " a6 = a4 / 100 a7 = rem temp = temp // chs(a6) // "." if a7 < 10 temp = temp // "0" end temp = temp // chs(a7) // " " temp = temp // chs(a5) // " " // chs(a4) // " -0.5 " // chs(a4) // " " putc /mus_~a8 ~temp < ++sd_cnt tput [SD,sd_cnt] /mus_~a8 ~temp < ++a8 if a8 = 128 a8 = 160 end Build the definition string data = "" loop for a3 = 1 to a4 ++a1 /* next record tget [ST,a1] temp temp = temp // pad(a5) Convert this to a hex string j = 0 loop for k = 1 to a5 if j = 0 j = 0x04 if temp{k} = "x" h = 0x08 else h = 0 end else if temp{k} = "x" h += j end j >>= 1 if j = 0 if h < 10 data = data // chs(h) else data = data // chr(55 + h) end if len(data) = 60 putc ~data ++sd_cnt tput [SD,sd_cnt] ~data data = "" end end end repeat repeat if len(data) > 0 putc ~data ++sd_cnt tput [SD,sd_cnt] ~data end putc > ] def ++sd_cnt tput [SD,sd_cnt] > ] def ++a1 /* skip terminating ":" tget [ST,a1] temp if temp{1} <> ":" dputc Error 2 stop end repeat putc /.b46 notdef [ 0 0 0 0 0 1 0 0 <> ] def ++sd_cnt tput [SD,sd_cnt] /.b46 notdef [ 0 0 0 0 0 1 0 0 <> ] def putc end ++sd_cnt tput [SD,sd_cnt] end a6 = t5 + 2000 putc /UniqueID ~a6 def ++sd_cnt tput [SD,sd_cnt] /UniqueID ~a6 def putc end ++sd_cnt tput [SD,sd_cnt] end putc /Bitfont~a6 exch definefont pop ++sd_cnt tput [SD,sd_cnt] /Bitfont~a6 exch definefont pop if a1 <> t2 dputc Error 1 stop end return *P XXV. build_long_slur_dict (t1,t2,t3) Purpose: construct a customized Postscript dictionary for one long slur Inputs: table SST contains data for long slurs int t1 table pointer to first entry int t2 table pointer to last data entry int t3 dictionary number (3 and climbing) int pt_cnt2 pointer to next available location in auxillary PostScript output table int sd_cnt pointer to next available location in the slur dictionary Output: table SD custormized Postscript dictionaries of slurs int pt_cnt2 pointer to next available location in auxillary PostScript output table int sd_cnt pointer to next available location in the slur dictionary procedure build_long_slur_dict (t1, t2, t3) str data.100 str temp.1000 int f,g,h int i,j,k int n int font,glyph int t1,t2,t3,t4,t5 int a1,a3,a4,a5,a6,a7,a8 int hh,kk getvalue t1,t2,t3 Add to the auxiliary PostScript output table a6 = t3 + 2000 ++pt_cnt2 tput [PT2,pt_cnt2] /Bitfont~a6 findfont 24 scalefont setfont putc ++sd_cnt tput [SD,sd_cnt] putc 9 dict dup begin ++sd_cnt tput [SD,sd_cnt] 9 dict dup begin putc /FontType 3 def ++sd_cnt tput [SD,sd_cnt] /FontType 3 def putc /FontMatrix [1 0 0 1 0 0] def ++sd_cnt tput [SD,sd_cnt] /FontMatrix [1 0 0 1 0 0] def a1 = t1 tget [SST,a1] temp if temp{1} <> "C" dputc Error 5 ~temp stop end if temp con "location" a3 = mpt temp = temp{a3+10..} tput [Y,1] ~temp tget [Y,1] hh kk end ++a1 tget [SST,a1] temp if temp{1} <> ":" dputc Error 6 ~temp stop end Determine height and width of this slur a4 = 0 /* height counter a5 = 0 /* max width loop for a3 = a1+1 to t2 /* t2 is end of table tget [SST,a3] temp temp = trm(temp) temp = temp // pad(1) if temp{1} = ":" /* terminating ":" if a3 <> t2 dputc Error 7 stop end else ++a4 /* increment height a6 = len(temp) if a6 > a5 a5 = a6 end end repeat a5 *= 4 /* convert to bit length With height now determined, you can now locate the slur h = hh + 50 /* magic number h = h * 10 * 24 k = 3150 - kk /* also a magic number k -= a4 /* position to bottom of image k = k + 1 /* another magic number k = k * 10 * 24 Convert h and k to decimals (i.e., divide by 1000) data = "" a6 = h / 1000 a7 = rem data = data // chs(a6) // "." if a7 < 100 data = data // "0" end if a7 < 10 data = data // "0" end data = data // chs(a7) // " " a6 = k / 1000 a7 = rem data = data // chs(a6) // "." if a7 < 100 data = data // "0" end if a7 < 10 data = data // "0" end data = data // chs(a7) ++pt_cnt2 tput [PT2,pt_cnt2] ~data moveto (\040) show Construct coordinates for font bounding box temp = "" a6 = a5 / 100 a7 = rem temp = temp // chs(a6) // "." if a7 < 10 temp = temp // "0" end temp = temp // chs(a7) // " " a6 = a4 / 100 a7 = rem temp = temp // chs(a6) // "." if a7 < 10 temp = temp // "0" end temp = temp // chs(a7) // " 0 0" putc /FontBBox [~temp ] def ++sd_cnt tput [SD,sd_cnt] /FontBBox [~temp ] def putc ++sd_cnt tput [SD,sd_cnt] putc /Encoding 256 array def ++sd_cnt tput [SD,sd_cnt] /Encoding 256 array def putc 0 1 255 {Encoding exch /.b46 notdef put} for ++sd_cnt tput [SD,sd_cnt] 0 1 255 {Encoding exch /.b46 notdef put} for putc Encoding ++sd_cnt tput [SD,sd_cnt] Encoding putc 32 /mus_32 put ++sd_cnt tput [SD,sd_cnt] 32 /mus_32 put putc putc /BuildChar putc {0 begin putc /char exch def putc /fontdict exch def putc /charname fontdict /Encoding get char get def putc putc /charinfo fontdict /CharData get charname get def putc putc /wx charinfo 0 get def putc /charbbox charinfo 1 4 getinterval def putc wx 0 charbbox aload pop setcachedevice putc putc charinfo 5 get charinfo 6 get true putc putc fontdict /imagemaskmatrix get putc dup 4 charinfo 7 get put putc dup 5 charinfo 8 get put putc charinfo 9 1 getinterval cvx putc imagemask putc end putc } def putc putc /BuildChar load 0 6 dict put putc ++sd_cnt tput [SD,sd_cnt] ++sd_cnt tput [SD,sd_cnt] /BuildChar ++sd_cnt tput [SD,sd_cnt] {0 begin ++sd_cnt tput [SD,sd_cnt] /char exch def ++sd_cnt tput [SD,sd_cnt] /fontdict exch def ++sd_cnt tput [SD,sd_cnt] /charname fontdict /Encoding get char get def ++sd_cnt tput [SD,sd_cnt] ++sd_cnt tput [SD,sd_cnt] /charinfo fontdict /CharData get charname get def ++sd_cnt tput [SD,sd_cnt] ++sd_cnt tput [SD,sd_cnt] /wx charinfo 0 get def ++sd_cnt tput [SD,sd_cnt] /charbbox charinfo 1 4 getinterval def ++sd_cnt tput [SD,sd_cnt] wx 0 charbbox aload pop setcachedevice ++sd_cnt tput [SD,sd_cnt] ++sd_cnt tput [SD,sd_cnt] charinfo 5 get charinfo 6 get true ++sd_cnt tput [SD,sd_cnt] ++sd_cnt tput [SD,sd_cnt] fontdict /imagemaskmatrix get ++sd_cnt tput [SD,sd_cnt] dup 4 charinfo 7 get put ++sd_cnt tput [SD,sd_cnt] dup 5 charinfo 8 get put ++sd_cnt tput [SD,sd_cnt] charinfo 9 1 getinterval cvx ++sd_cnt tput [SD,sd_cnt] imagemask ++sd_cnt tput [SD,sd_cnt] end ++sd_cnt tput [SD,sd_cnt] } def ++sd_cnt tput [SD,sd_cnt] ++sd_cnt tput [SD,sd_cnt] /BuildChar load 0 6 dict put ++sd_cnt tput [SD,sd_cnt] putc /imagemaskmatrix [100 0 0 -100 0 0] def ++sd_cnt tput [SD,sd_cnt] /imagemaskmatrix [100 0 0 -100 0 0] def putc ++sd_cnt tput [SD,sd_cnt] putc /CharData 2 dict def ++sd_cnt tput [SD,sd_cnt] /CharData 2 dict def putc CharData begin ++sd_cnt tput [SD,sd_cnt] CharData begin Construct first 9 elements of def matrix temp = "[ 0 0 0 " a6 = a5 / 100 a7 = rem temp = temp // chs(a6) // "." if a7 < 10 temp = temp // "0" end temp = temp // chs(a7) // " " a6 = a4 / 100 a7 = rem temp = temp // chs(a6) // "." if a7 < 10 temp = temp // "0" end temp = temp // chs(a7) // " " temp = temp // chs(a5) // " " // chs(a4) // " -0.5 " // chs(a4) // " " putc /mus_32 ~temp < ++sd_cnt tput [SD,sd_cnt] /mus_32 ~temp < Build the definition strings data = "" loop for a3 = 1 to a4 ++a1 /* next record tget [SST,a1] temp This is already a hex string loop for a8 = 1 to len(temp) data = data // temp{a8} if len(data) = 60 putc ~data ++sd_cnt tput [SD,sd_cnt] ~data data = "" end repeat repeat if len(data) > 0 putc ~data ++sd_cnt tput [SD,sd_cnt] ~data end putc > ] def ++sd_cnt tput [SD,sd_cnt] > ] def putc /.b46 notdef [ 0 0 0 0 0 1 0 0 <> ] def ++sd_cnt tput [SD,sd_cnt] /.b46 notdef [ 0 0 0 0 0 1 0 0 <> ] def putc end ++sd_cnt tput [SD,sd_cnt] end a6 = t3 + 2000 putc /UniqueID ~a6 def ++sd_cnt tput [SD,sd_cnt] /UniqueID ~a6 def putc end ++sd_cnt tput [SD,sd_cnt] end putc /Bitfont~a6 exch definefont pop ++sd_cnt tput [SD,sd_cnt] /Bitfont~a6 exch definefont pop return *P XXVI. vpage_limits (01/05/09) Purpose: determine top and bottom page limits ignoring the caption at the bottom Inputs: gstr The struction of this string was determined by the instruction setup gstr,300,3100,3 According to the documentation, the first 20 bytes contain display information. In particular, bytes 13-14 contain the top display boundary; and bytes 17-18 contain the bottom display boundary. The top boundary, we can use; but the bottom boundary includes the bottom caption, so we must look above this. Output: int top_limit int bottom_limit procedure vpage_limits int a1,a2,a3,a4,a5 Get top limit top_limit = 10000 a3 = 20 loop for a1 = 1 to 3099 loop for a2 = 1 to 300 ++a3 if gstr{a3} <> chr(0) top_limit = a1 goto BBB end repeat repeat BBB: Get bottom limit Step 1: determine actual bottom limit a5 = 0 loop for a1 = 3050 to 1 step -1 loop for a2 = 1 to 300 a3 = a1 * 300 + a2 + 20 if gstr{a3} <> chr(0) a5 = a1 goto BBB1 end repeat repeat BBB1: bottom_limit = a5 if a5 < 2800 /* In this case, there does not appear to be return /* a caption. Use the real bottom limit. end Step 2: If caption appears to be present, look for beginning of (5 dot wide) space above caption loop for a1 = a5 to 1 step -1 a4 = 0 loop for a2 = 1 to 300 a3 = a1 * 300 + a2 + 20 if gstr{a3+1200} <> chr(0) a4 = 1 else if gstr{a3+900} <> chr(0) a4 = 1 else if gstr{a3+600} <> chr(0) a4 = 1 else if gstr{a3+300} <> chr(0) a4 = 1 else if gstr{a3} <> chr(0) a4 = 1 end end end end end if a4 = 1 a2 = 300 end repeat if a4 = 0 a5 = a1 goto BBB2 end repeat BBB2: if a5 < 10 /* in this case we have junk spread all over the page. return /* bottom_limit has already been set above. end Step 3: Look for new bottom_limit a4 = 0 loop for a1 = a5 to 1 step -1 loop for a2 = 1 to 300 a3 = a1 * 300 + a2 + 20 if gstr{a3} <> chr(0) a4 = a1 goto BBB3 end repeat repeat BBB3: bottom_limit = a4 activate gstr,0,-2900,1 getk k return *P XXVI. hpage_limits (01/05/09) Purpose: determine left and right page limits for those pages that do not have a system Inputs: gstr The structure of this string was determined by the instruction setup gstr,300,3100,3 According to the documentation, the first 20 bytes contain display information. In particular, bytes 13-14 contain the top display boundary; and bytes 17-18 contain the bottom display boundary. The top boundary, we can use; but the bottom boundary includes the bottom caption, so we must look above this. Output: int left_limit int right_limit procedure hpage_limits str line.300 bstr bline.2400,bline2.2400 int a1,a2,a3 Get limits left_limit = 10000 right_limit = 10000 loop for a1 = 1 to 3090 a2 = (a1 - 1) * 300 + 21 line = gstr{a2,300} bline = cbi(line) bline = bline // zpd(2400) bline2 = rev(bline) if bline con "1" a3 = mpt if a3 < left_limit left_limit = a3 end end if bline2 con "1" a3 = mpt if a3 < right_limit right_limit = a3 end end repeat if left_limit = 10000 left_limit = 1200 right_limit = 1200 return end right_limit = 2401 - right_limit return #endif run