source: trunk/lisp/lmio1/ctest.lisp @ 252

Last change on this file since 252 was 252, checked in by rjs, 3 years ago

Initial versions.

File size: 36.7 KB
Line 
1;;-*- MODE: LISP; PACKAGE: USER; IBASE: 10.; BASE: 10. -*-
2
3(DEFCONST CTEST-BOARD-TYPE 'LG684)  ;OR MPG216
4
5;Continuity Tester Interface
6
7(DEFUN BYTE-FIELD (BITS OVER)
8  (+ BITS (LSH OVER 6)))
9
10(defconst ctest-%%pin  (byte-field 7 00))       ;pin number (all type boards)
11
12;The below code basically copied from NEWWL;MPG216 >.  The fields are the
13; same altho the names have been changed to protect the innocent.
14
15;SOME BYTE POINTERS FOR EXTRACTING FIELDS
16
17(defconst mpg216-%conn   (byte-field 1 25))     ;connector bit. (sign on 10).
18(defconst mpg216-%DIPPNL (byte-field 3 22))     ;PANEL NUMBER
19(defconst mpg216-%DIPG   (byte-field 3 19))     ;DIP GROUP
20(defconst mpg216-%DIPS   (byte-field 6 13))     ;DIP SLOT
21(defconst mpg216-%DIPOF  (byte-field 6 07))     ;DIP OFFSET
22
23(defconst mpg216-%CNPPNL (byte-field 3 22))     ;PANEL NUMBER (MUST BE SAME AS DIP)
24(defconst mpg216-%CNPG   (byte-field 3 19))     ;CONN GROUP  ( "        "       )
25(defconst mpg216-%CNPJK  (byte-field 1 07))     ;CONNECTOR JACK BIT
26;(defconst mpg216-%CONP   (byte-field 9 00))    ;CONNECTOR PIN #
27                                                ;  (AND JACK NUMBER <PINS 1-2*26>)
28
29(defconst mpg216-GPINS 400)             ;NOMEN FOR "G" PINS ON BOARD STARTS AT 400
30                                        ; 401 IS "G1", ETC.
31(defconst mpg216-MXPNL 5)               ;max number of panels wrappable at once
32(defconst mpg216-NGRPS 6)               ;PG216-180 HAS 6 GROUPS
33(defconst mpg216-GRPCOL 5)      ;# COLS IN GROUP
34(defconst mpg216-GRPROW 6)      ;# ROWS IN GROUP
35(defconst mpg216-GRPDIP (* mpg216-GRPROW mpg216-GRPCOL))        ;# DIPS IN GROUP
36(defconst mpg216-MXCNP1 40)     ;MAX # CONNECTOR PINS FOR J1
37(defconst mpg216-MXCNP2 50)     ;MAX # CONNECTOR PINS FOR J2
38(defconst mpg216-J1TO2 2)               ;J1 IS OFFSET 2 PINS TO RIGHT OF J2
39
40;JACKSZ:        MXCNP1
41;               MXCNP2
42
43
44;The 8136-PG216 consists of 180 dip slots, organized into
45;6 groups of 30 dips each.
46;The groups are labeled A-F, with group A to left
47;Withhin a group, slots are numbered:
48;       5  4  3  2  1
49;       10 9 ....   6
50;       15   ....   11
51;       20   ....   16
52;       25   ....   21
53;       30   ....   26
54
55;(All coordinates are from DIP side, assuming Scotchflex conns
56; are at the top)
57
58
59;AUGAT-X8136-PG216 CONNECTOR PIN FORMAT PRINTS AS #LJ#-#
60;WHERE L IS THE GROUP.  THE J IS LITERAL.  THE FIRST DIGIT IS THE PANEL
61;AND THE SECOND IS THE JACK.  PIN IS LAST
62
63;     15    12     9                 0     LM bit numbering
64;______|_____|_____|_____|_____|_____|
65;|    20    23    26                35     PDP-10 bit numbering
66;|  3  |  3  |   | |        9        |
67;|_____|_____|___|_|_________________|
68;     |    |     |      |
69;     |    |     |      |------------>PIN
70;     |    |     |
71;     |    |     |-------------------JACK 01, 12
72;     |    |
73;     |    |--------------------------># GROUP 
74;     |
75;     |-------------------------------># PANEL
76
77(DEFUN CTEST-LOC (LOC)
78  (SELECTQ CTEST-BOARD-TYPE
79    (MPG216 (MPG216-PRNLOC LOC))
80    (LG684 (LG684-PRNLOC LOC))
81    (OTHERWISE (FERROR NIL ""))))
82
83(DEFUN CTEST-GETLOC (STR &OPTIONAL BEG LIM)
84  (SELECTQ CTEST-BOARD-TYPE
85    (MPG216 (MPG216-GETLOC STR BEG LIM))
86    (LG684 (LG684-GETLOC STR BEG LIM))
87    (OTHERWISE (FERROR NIL ""))))
88
89(DEFUN CTEST-MAPLOC (LOC)
90  (SELECTQ CTEST-BOARD-TYPE
91    (MPG216 (MPG216-MAPLOC LOC))
92    (LG684 (LG684-MAPLOC LOC))
93    (OTHERWISE (FERROR NIL ""))))
94
95
96(defun mpg216-prnloc (loc &aux ans)
97  (let ((panel (ldb mpg216-%DIPPNL loc))
98        (group (ldb mpg216-%DIPG loc))
99        (conn (ldb mpg216-%CONN loc))
100        (pin (ldb ctest-%%pin loc)))
101    (cond ((zerop conn)
102           (let ((slot (ldb mpg216-%DIPS loc))
103                 (offset (ldb mpg216-%DIPOF loc)))
104             (setq ans (format nil "~D~C~2,48D" panel (+ #/@ group) slot))
105             (cond ((not (zerop offset))
106                    (setq ans (string-append ans (format nil "@~2,48D" offset)))))))
107          (t (setq ans (format nil "~D~CJ~D"
108                               panel (+ #/@ group) (1+ (ldb mpg216-%CNPJK loc))))))
109    (cond ((and (zerop conn)
110                (>= pin mpg216-GPINS))
111           (SETQ ANS (format nil "~A-~1D" ANS (- pin mpg216-GPINS))))
112          (t (SETQ ANS (format nil "~A-~2,48D" ANS pin)))))
113  ANS)
114
115;All calculations are done from the dip side.
116
117;(0,0) at lower left hand corner in left handed coordinate system.
118;Dip sockets are arranged in 5x6 groups.  These 30 dip groups come
119;in pairs.  Each group comes with a pair of Scotch Flex(R) connectors
120;labeled "J1" and "J2".  There can be up to 6 30 dip groups on one
121;board.  The horizontal spacing between groups is 2.700".
122
123;There are 5 panels, vertically arranged.  The vertical spacing
124;is 7.500". 
125
126;5A30(8) is at (0,0).  5AJ2-26 is at (500,6100).  5AJ1-26 is at (500, 6400).
127;--5A30(10)
128;It follows that 5B30(8) is at (2700,0)
129
130;UMLCOL__GRPROW         ;UML INTERCHANGES ROWS AND COLUMNS
131;UMLROW__GRPCOL
132(defconst mpg216-PNLOFT 8100)   ;8.100" VERTICAL SPACING BETWEEN PANELS
133(defconst mpg216-GXOFST 2700)   ;2.700" GROUP HORIZONTAL SPACING
134(defconst mpg216-XDIPSP  500)   ; .500" DIP HORIZONTAL SPACING
135(defconst mpg216-YDIPSP 1100)   ;1.100" DIP VERTICAL SPACING
136(defconst mpg216-GNDXOF  100)   ; .100" X OFFSET FOR TWP GROUND PINS
137(defconst mpg216-BRDGND   10)   ; PIN 10 IS DEDICATED GROUND
138(defconst mpg216-BRDPWR   20)   ; PIN 20 IS DEDICATED POWER
139;CONNECTORS
140(defconst mpg216-JXOFST    0)   ; .000" X OFFSET FOR JACKS
141(defconst mpg216-JYOFST 6700)   ;6.700" Y OFFSET FOR J2
142(defconst mpg216-JYOFS1  300)   ; .300" Y OFFSET FROM J2 TO J1
143
144(defvar twenty-pin-socket-xoff nil)
145(defvar twenty-pin-socket-yoff nil)
146(defconst twenty-pin-dipsoc-xpinsp  300)        ; .300" DIP PIN HORIZONTAL SPACING
147(defconst twenty-pin-dipsoc-ypinsp  100)        ; .100" DIP PIN VERTICAL SPACING
148(defvar flat-cable-conn-xoffs nil)
149(defvar flat-cable-conn-yoffs nil)
150(defconst flat-cable-pxpnsp  100)       ; .100" CONNECTOR PIN VERTICAL SPACING
151(defconst flat-cable-pypnsp  100)       ; .100" CONNECTOR PIN HORIZONTAL SPACING
152
153(defun ctest-conn-and-socket-init nil
154  (setq twenty-pin-socket-xoff (make-array nil art-q 20)
155        twenty-pin-socket-yoff (make-array nil art-q 20)
156        flat-cable-conn-xoffs (make-array nil art-q 51)
157        flat-cable-conn-yoffs (make-array nil art-q 51))
158  (dotimes (p 20.)
159    (as-1 (* (cond ((<= p 9) 0) ;First col of pins is on the left (DIP side)
160                   (t 1))
161             twenty-pin-dipsoc-xpinsp)
162          twenty-pin-socket-xoff
163          p)
164    (as-1 (* (cond ((<= p 9)
165                    (- 9 p))
166                   (t (- p 10.)))
167             twenty-pin-dipsoc-ypinsp)
168          twenty-pin-socket-yoff
169          p))
170  (dolist (maxp '(50 40 26))
171    (let ((xoff-arr (make-array nil art-q maxp))
172          (yoff-arr (make-array nil art-q maxp))
173          (hmaxp (// maxp 2)))
174      (dotimes (p maxp)
175        (as-1 (- (* (- (1- hmaxp) (\ p hmaxp)) flat-cable-pxpnsp)
176                 flat-cable-pxpnsp)     ;Pin 25 (which doesnt really exist) is one click
177              xoff-arr                  ; to the right of the 1a5-1 to 10 line of pins
178            p)
179      (as-1 (* (cond ((< p hmaxp) 1)
180                     (t 0))
181               flat-cable-pypnsp)
182            yoff-arr
183            p)
184      (as-1 xoff-arr flat-cable-conn-xoffs maxp)
185      (as-1 yoff-arr flat-cable-conn-yoffs maxp)))))
186   
187(defun mpg216-getloc (STR BEG LIM &AUX C VAL-LIST IDX)
188  (IF (NULL BEG) (SETQ BEG 0))
189  (IF (NULL LIM) (SETQ LIM (ARRAY-ACTIVE-LENGTH STR)))
190  (MULTIPLE-VALUE (C VAL-LIST IDX)
191    (LNPARSE '("#L#-#(#L#-#)" "#L#-#(#)" "#L#-#"
192               "#L#@#-#(#)" "#L#@#-#" "#LJ#-#") STR BEG LIM))
193  (SELECTQ C (0 (SETQ VAL-LIST (CDDDDR VAL-LIST))  ;ADAPTOR FROB, FLUSH THAT ONE
194                (DPB (CAR VAL-LIST) MPG216-%CNPPNL
195                  (DPB (CADR VAL-LIST) MPG216-%CNPG
196                     (DPB (CADDR VAL-LIST) MPG216-%DIPS
197                          (DPB (CADDDR VAL-LIST) CTEST-%%PIN 0)))))
198             (1 (DPB (CAR VAL-LIST) MPG216-%CNPPNL
199                  (DPB (CADR VAL-LIST) MPG216-%CNPG
200                     (DPB (CADDR VAL-LIST) MPG216-%DIPS
201                          (DPB (CAR (CDDDDR VAL-LIST)) CTEST-%%PIN 0)))))
202             (2 (DPB (CAR VAL-LIST) MPG216-%CNPPNL
203                  (DPB (CADR VAL-LIST) MPG216-%CNPG
204                     (DPB (CADDR VAL-LIST) MPG216-%DIPS
205                          (DPB (CADDDR VAL-LIST) CTEST-%%PIN 0)))))
206             (3 (DPB (CAR VAL-LIST) MPG216-%CNPPNL
207                  (DPB (CADR VAL-LIST) MPG216-%CNPG
208                     (DPB (CADDR VAL-LIST) MPG216-%DIPS
209                          (DPB (CADDDR (CDDR VAL-LIST)) CTEST-%%PIN 0)))))
210             (4 (DPB (CAR VAL-LIST) MPG216-%CNPPNL
211                  (DPB (CADR VAL-LIST) MPG216-%CNPG
212                     (DPB (CADDR VAL-LIST) MPG216-%DIPS
213                         (DPB (CADDDR VAL-LIST) MPG216-%DIPOF
214                            (DPB (CAR (CDDDDR VAL-LIST)) CTEST-%%PIN 0))))))
215             (5 (DPB (CAR VAL-LIST) MPG216-%CNPPNL
216                  (DPB (CADR VAL-LIST) MPG216-%CNPG
217                     (DPB 1 MPG216-%CONN
218                        (DPB (1- (CADDR VAL-LIST)) MPG216-%CNPJK
219                           (DPB (CADDDR VAL-LIST) CTEST-%%PIN 0)))))))
220)
221
222(defun mpg216-maploc (loc)  ;returns x and y, but swap these to get tester coords
223  (prog (x y panel group conn pin slot offset)
224        (setq panel (ldb mpg216-%DIPPNL loc)
225              group (ldb mpg216-%DIPG loc)
226              conn  (ldb mpg216-%CONN loc)
227              pin   (ldb ctest-%%pin loc))
228        (cond ((> panel mpg216-MXPNL)
229               (ferror nil "panel number too high ~s" panel))
230              ((> group mpg216-NGRPS)
231               (ferror nil "group number too high ~s" group)))
232        (setq y (* mpg216-PNLOFT (- mpg216-MXPNL panel))
233              x (* (1- group) mpg216-GXOFST))
234        (cond ((zerop conn)
235               (setq slot (1- (ldb mpg216-%DIPS loc))
236                     offset (ldb mpg216-%DIPOF loc))
237               (let ((xpos (\ slot mpg216-grpcol))
238                     (ypos (// slot mpg216-grpcol)))
239                 (setq x (+ x (* (1- (- mpg216-grpcol xpos)) mpg216-XDIPSP)
240                              (ar-1 TWENTY-PIN-SOCKET-xoff (1- pin)))
241                       y (+ y (* (1- (- mpg216-grprow ypos)) mpg216-YDIPSP)
242                              (ar-1 TWENTY-PIN-SOCKET-yoff (1- pin))))))
243              (t (let ((jack (ldb mpg216-%CNPJK loc)))
244                   (setq y (+ y mpg216-jyofst))  ;vert offset to j2
245                   (cond ((= jack 0)
246                          (setq y (+ y mpg216-jyofs1))   ;additional offset to j1
247                          (cond ((> pin (// mpg216-mxcnp1 2))  ;in bottom row?
248                                 (setq pin (+ pin 5))))        ;j2's bottom row starts
249                                                               ; +5 pins w.r.t j1
250                          (setq pin (+ pin mpg216-j1to2))))  ;and j1 is displaced 2 pins right
251                   (setq x (+ x (ar-1 (ar-1 flat-cable-conn-xoffs 50.) (1- pin)))
252                         y (+ y (ar-1 (ar-1 flat-cable-conn-yoffs 50.) (1- pin)))))))
253        (return x y)))
254
255
256(DEFUN LNPARSE (PATTERN-LIST STR BEG LIM)
257  (PROG (PL MATCHP ANS IDX C)
258        (SETQ PL PATTERN-LIST C 0)
259    L   (COND ((NULL PL) (RETURN NIL)))
260        (MULTIPLE-VALUE (MATCHP ANS IDX)
261           (LN-PMATCH (CAR PL) STR BEG LIM))
262        (COND (MATCHP (RETURN C ANS IDX)))
263        (SETQ PL (CDR PL) C (1+ C))
264        (GO L)))
265
266(DEFUN LN-PMATCH (PAT STR BEG LIM)
267   (PROG (PIDX PLIM IDX ANS MATCHP VAL)
268         (SETQ PIDX 0 PLIM (ARRAY-ACTIVE-LENGTH PAT)
269               IDX BEG)
270    L    (COND ((NOT (< IDX LIM)) (RETURN NIL)))
271         (MULTIPLE-VALUE (MATCHP VAL IDX)
272             (LN-PMATCH-CH (AR-1 PAT PIDX) STR IDX LIM))
273         (COND ((NULL MATCHP) (RETURN NIL)))
274         (COND (VAL (SETQ ANS (NCONC ANS (LIST VAL)))))
275         (COND ((= (SETQ PIDX (1+ PIDX)) PLIM)
276                (RETURN T ANS IDX)))
277         (GO L)))
278
279(DEFUN LN-PMATCH-CH (CH STR IDX LIM)
280   (COND ((EQ CH #/#)
281          (LN-PMATCH-NUM STR IDX LIM))
282         ((EQ CH #/L)           ;any DEC letter
283          (LN-PMATCH-LET STR IDX LIM))
284         ((EQ CH #/P)           ;"paddle" letter ABCDEF
285          (LN-PMATCH-LET STR IDX LIM 6))
286         ((= CH (CHAR-UPCASE (AR-1 STR IDX)))
287          (PROG NIL (RETURN T NIL (1+ IDX))))
288))
289
290
291(DEFUN LN-PMATCH-NUM (STR IDX LIM)
292   (PROG (ANS CH)
293         (COND ((OR (NOT (< IDX LIM))
294                    (NOT (AND (>= (SETQ CH (AR-1 STR IDX)) #/0)
295                              (<= CH #/9))))
296                (RETURN NIL)))
297         (SETQ ANS (- CH #/0))
298      L  (COND ((OR (NOT (< (SETQ IDX (1+ IDX)) LIM))
299                    (NOT (AND (>= (SETQ CH (AR-1 STR IDX)) #/0)
300                              (<= CH #/9))))
301                (RETURN T ANS IDX)))
302         (SETQ ANS (+ (* ANS 10.) (- CH #/0)))
303         (GO L)))
304
305(DEFUN LN-PMATCH-LET (STR IDX LIM &OPTIONAL (MAX 22.))
306  (PROG (CH)
307        (COND ((AND (< IDX LIM)
308                    (>= (SETQ CH (CHAR-UPCASE (AR-1 STR IDX))) #/A)
309                    (<= CH (+ #/A MAX)))
310               (RETURN T (CTEST-DEC-LETTER-TO-NUMBER (- CH #/@)) (1+ IDX))))))
311
312(DEFUN MATCH-TEST NIL
313  (DO ((x) (y) (loc)) (())
314    (PRINT (CTEST-LOC (setq loc (CTEST-GETLOC (READLINE)))))
315    (multiple-value (x y)
316      (ctest-maploc loc))
317    (format t "x=~d,y=~d~%" x y)
318    ))
319
320(DECLARE (SPECIAL LEFT-PROBE RIGHT-PROBE))
321
322(DEFUN LOC-TEST (&optional (probe-ob left-probe))
323  (DO ((x) (y) (loc) (XE) (YE)) (())
324    (CTEST-LOC (setq loc (CTEST-GETLOC (READLINE))))
325    (multiple-value (y x)       ;Y and X swapped
326      (ctest-maploc loc))
327    (format t "x=~d,y=~d" x y)
328    (<- PROBE-OB ':GOTO-LOC LOC)
329    (<- PROBE-OB ':PROBE-DOWN)
330    (MULTIPLE-VALUE (XE YE)
331      (<- PROBE-OB ':CLIMB-ON-PIN))
332    (FORMAT T "~%XERR ~S, YERR ~S" XE YE))
333    )
334
335(defvar ctest-retry-count 0)
336
337;SIGNAL-NAME is for printouts, plus it does different things for power and ground
338(DEFUN TEST-WIRE (SIGNAL-NAME LOC1 LOC2)
339  (MULTIPLE-VALUE-BIND (Y1 X1)
340      (CTEST-MAPLOC LOC1)
341    (MULTIPLE-VALUE-BIND (Y2 X2)
342        (CTEST-MAPLOC LOC2)
343      (COND ((< X1 X2)          ;left probe takes wire with greater X
344             (SETQ X1 (PROG1 X2 (SETQ X2 X1)))
345             (SETQ Y1 (PROG1 Y2 (SETQ Y2 Y1)))))
346  (setq ctest-retry-count 0)
347  (error-restart
348      (prog (lx rx lxdiff rxdiff cxdiff lxe lye rxe rye)
349            (cond ((equal signal-name "NC") (return t)))  ;that one isnt there!
350        L0 (setq lx (<- left-probe ':xpos)
351                 rx (<- right-probe ':xpos))
352           (setq lxdiff (- x1 lx)
353                 rxdiff (- x2 rx)
354                 cxdiff (- lx rx))       ;current dist between probes
355;In code below, we assume if probes are 250. mills apart in x direction, they cannot
356; collide even if y's cross.
357           (cond ((and (> lxdiff 0)                ;left probe moving away,
358                       (> (+ lxdiff cxdiff) 250.))  ;and far enuf away
359                  (<- left-probe ':goto x1 y1)     ;safe to move it.
360                  (<- right-probe ':goto x2 y2))
361                 ((and (> (minus rxdiff) 0)        ;same stuff, right probe
362                       (> (+ (minus rxdiff) cxdiff) 250.))
363                  (<- right-probe ':goto x2 y2)
364                  (<- left-probe ':goto x1 y1))
365                 ((> (min cxdiff (- x1 rx) (- lx x2) (- x1 x2)) 250.)
366                  (<- right-probe ':goto x2 y2)    ;they are far apart and will stay far apart
367                  (<- left-probe ':goto x1 y1))
368;Try to arrange the second motion to involve a x-motion of at least 250 mills toward
369; the other arm.
370                 ((> (minus lxdiff) 250.)
371                  (<- right-probe ':goto x2 y2)
372                  (<- left-probe ':goto x1 y1))
373                 ((> rxdiff 250.)
374                  (<- left-probe ':goto x1 y1)
375                  (<- right-probe ':goto x2 y2))
376;cause one arm to step away from the other by 20 steps (about .2 inch), then try again.
377                 ((zerop lxdiff)
378                  (<- right-probe ':step-x -20.)
379                  (go L0))
380                 (t (<- left-probe ':step-x 20.)
381                    (go L0)))
382           (<- left-probe ':probe-down)
383           (multiple-value (lxe lye) (<- left-probe ':climb-on-pin))
384           (<- right-probe ':probe-down)
385           (multiple-value (rxe rye) (<- right-probe ':climb-on-pin))
386           (cond ((eq (ctest-test-cont signal-name t) 'win)
387                  (<- LEFT-PROBE ':APPARENT-ERROR LXE LYE)  ;WON, SO PROBES MUST BE IN RIGHT
388                  (<- RIGHT-PROBE ':APPARENT-ERROR RXE RYE)  ;PLACE
389                  (return t))))))))
390
391;definitions below basically copied from MC;WL;LG684 517
392
393(DEFCONST LG684-%DIPG (BYTE-FIELD 4 19))        ;DIP GROUP (The letter)
394(DEFCONST LG684-%DIPS (BYTE-FIELD 6 13))        ;DIP SLOT  (The number)
395(DEFCONST LG684-%DIPOF (BYTE-FIELD 6 07))       ;DIP OFFSET
396
397(DEFCONST LG684-%CONT (BYTE-FIELD 1 07))        ;CONNECTOR TYPE 0 DEC  1 FLAT CABLE "J"
398(DEFCONST LG684-%CONN (BYTE-FIELD 4 23))        ;CONNECTOR NUMBER (LETTER OR JACK #)
399;(DEFCONST LG684-%CONP (BYTE-FIELD 9 00))       ;CONNECTOR PIN #
400
401(DEFCONST LG684-GPINS 400)              ;NOMEN FOR "G" PINS ON BOARD STARTS AT 400
402                                        ; 401 IS "G1", ETC.
403;BRDGND__=10                            ; PIN 10 IS DEDICATED GROUND
404;BRDPWR__=20                            ; PIN 20 IS DEDICATED POWER
405(DEFCONST LG684-MXDPIN 36)              ;MAXIMUM NUMBER OF DEC PINS/CONNECTOR
406(DEFCONST LG684-NGRPS 6)                        ;max for group (the letter)
407(DEFCONST LG684-MAXCON 12)              ;max for the jack (Jnn)
408
409;The L8X30 board has an area of 16 pin DIP's, in 7 rows (A-H), columns 5-30
410; and an 2 areas of 20 pin dips: rows A-F cols 1-4, and row J cols 1-30
411; (There is no H row for columns 1-4)
412
413;The LG684 board consists of 6 rows of 30 dips
414;Row A, slot1 is the upper left (with connector paddles up,
415; and from DIP side)
416
417;AUGAT-LG684 CONNECTOR PIN FORMAT PRINTS AS J#-# OR LL#
418;THE J IS LITERAL.
419
420;     15    12     9                 0   LM bit numbering
421;______|_____|_____|_____|_____|_____|
422;|        22      26                35   PDP-10 bit numbering
423;|       |1|   4   |        9        |
424;|_______|_|_______|_________________|
425;         |    |        |
426;         |    |        |------------>PIN
427;         |    |   
428;         |    |----------------------CONNECTOR NUMBER (JACK OR ROW LETTER)
429;         |
430;         |--------------------------->CONNECTOR TYPE 0 DEC, 1 FLAT CABLE
431     
432
433
434
435
436;All calculations are done from the DIP side.
437
438;(0,0) at LOWER left hand corner in left handed coordinate system.
439;X+ to right, Y+ is up
440;0,0 corresponds to FV1 of DEC connectors.
441
442(DEFCONST LG684-XDIPSP  500)    ; .500" DIP HORIZONTAL SPACING
443(DEFCONST LG684-YDIPSP 1100)    ;1.100" DIP VERTICAL SPACING
444(DEFCONST LG684-XGRPOF 200)     ;HORIZONTAL DISTANCE FROM ORIGIN TO DIP PIN10 OF F1
445(DEFCONST LG684-YGRPOF 600)     ;VERTICAL DISTANCE FROM ORIGIN TO DIP PIN10 OF F1
446
447(DEFCONST LG684-XPINSP  300)    ; .300" DIP PIN HORIZONTAL SPACING
448(DEFCONST LG684-YPINSP  100)    ; .100" DIP PIN VERTICAL SPACING
449(DEFCONST LG684-XGNDOFF -100)   ;OFFSET FROM DIP SLOT ORIGIN (ON EXTRA GROUND ROW) TO
450                                ; FIRST DIP PIN ROW
451;CONNECTORS, SCOTCHFLEX
452(DEFCONST LG684-FCXOFF 100)     ;.1" RIGHT FOR FIRST PIN OF FLAT CABLE CONNECTORS
453(DEFCONST LG684-FCYOFF 7400)    ;7.4" up to first pin of J2 relative to origin
454(DEFCONST LG684-FCYOF2 300)     ;.3" up for first pin of J1 relative to J2
455(DEFCONST LG684-FCJ3OF 2800)    ;2.8" RIGHT FOR FIRST PIN OF J3
456(DEFCONST LG684-FCGOF 5100)     ;5.1" RIGHT FOR FIRST PIN OF J5
457
458;CONNECTORS, DEC
459(DEFCONST LG684-DECCNY 0)       ;0.0" UP TO BOTTOM ROW OF DEC CONNECTORS
460(DEFCONST LG684-DCPINO 200)     ;.2" UP FROM BOTTOM TO SECOND ROW
461(DEFCONST LG684-DECX1 2700)     ;2.7" LEFT FOR LARGE CONNECTOR SPACES
462(DEFCONST LG684-DECX2 2600)     ;2.6" LEFT FOR SMALL CONNECTOR SPACES
463(DEFCONST LG684-GAP1T2 (- LG684-DECX2 1900))    ; THE SMALLER GAP BETWEEN DEC PADDLES
464(DEFCONST LG684-DCPINS 1900)    ;1.9" RIGHT FOR PIN A1 RELATIVE TO START OF CONNECTOR
465(DEFCONST LG684-DCPNSP 100)     ;.1" BETWEEN PINS HORIZONTALLY
466(DEFCONST LG684-DCGRSP 200)     ;.2" BETWEEN GROUPS OF PINS
467
468(DEFVAR LG684-PADDLE-XOFFS NIL)
469(DEFVAR LG684-PADDLE-YOFFS NIL)
470
471(DEFVAR LG684-JACKSZ NIL)               ;array, for each J, max # pins. J0 illegal.
472(DEFVAR LG684-JACK-XOFFS NIL)
473(DEFVAR LG684-JACK-YOFFS NIL)
474
475
476(DEFUN LG684-PRNLOC (LOC &AUX ANS)
477  (let ((group (ldb LG684-%DIPG loc))
478        (conn (ldb LG684-%CONN loc))
479        (pin (ldb ctest-%%pin loc)))
480    (cond ((zerop conn)
481           (let ((slot (ldb LG684-%DIPS loc))
482                 (offset (ldb LG684-%DIPOF loc)))
483             (setq ans (format nil "~C~2,48D" (+ #/@ group) slot))
484             (cond ((not (zerop offset))
485                    (setq ans (string-append ans (format nil "@~2,48D" offset)))))))
486          ((ZEROP (LDB LG684-%CONT LOC))        ;DEC edge connector
487           (SETQ ANS (FORMAT NIL "~C" (+ #/@ CONN))))   ;paddle letter just ABCDEF
488          (t (setq ans (format nil "J~D" CONN))))
489    (cond ((and (zerop conn)
490                (>= pin LG684-GPINS))
491           (SETQ ANS (format nil "~A-~1D" ANS (- pin LG684-GPINS))))    ;ground pin
492          ((AND (NOT (ZEROP CONN))
493                (ZEROP (LDB LG684-%CONT LOC)))
494           (SETQ ANS (FORMAT NIL "~A~C~D"
495                             ANS
496                             (CTEST-NUMBER-TO-DEC-LETTER (LSH PIN -1))
497                             (1+ (LOGAND PIN 1)))))
498          (t (SETQ ANS (format nil "~A-~2,48D" ANS pin)))))
499  ANS)
500
501(DEFUN LG684-INIT (&AUX JN DX)
502  (SETQ LG684-JACKSZ (MAKE-ARRAY NIL ART-Q 13.))        ;J0 illegal
503  (DOTIMES (C 12.)
504    (AS-1 (IF (BIT-TEST 1 C) 40 50)
505          LG684-JACKSZ
506          (1+ C)))
507  (SETQ LG684-JACK-XOFFS (MAKE-ARRAY NIL ART-Q 13)
508        LG684-JACK-YOFFS (MAKE-ARRAY NIL ART-Q 13))
509  (SETQ JN 1)
510  (DOTIMES (JGROUP 3)   ;3 groups, 4 connectors each
511    (AS-1  (+ LG684-FCXOFF (* LG684-FCGOF JGROUP)) LG684-JACK-XOFFS JN) ;eg J1
512    (AS-1  (+ LG684-FCYOFF LG684-FCYOF2) LG684-JACK-YOFFS JN)
513    (SETQ JN (1+ JN))
514    (AS-1  (+ LG684-FCXOFF (* LG684-FCGOF JGROUP)) LG684-JACK-XOFFS JN) ;eg J2
515    (AS-1  LG684-FCYOFF LG684-JACK-YOFFS JN)
516    (SETQ JN (1+ JN))
517    (AS-1  (+ LG684-FCXOFF LG684-FCJ3OF (* LG684-FCGOF JGROUP)) LG684-JACK-XOFFS JN)    ;eg J3
518    (AS-1  (+ LG684-FCYOFF LG684-FCYOF2) LG684-JACK-YOFFS JN)
519    (SETQ JN (1+ JN))
520    (AS-1  (+ LG684-FCXOFF LG684-FCJ3OF (* LG684-FCGOF JGROUP)) LG684-JACK-XOFFS JN)    ;eg J4
521    (AS-1  LG684-FCYOFF LG684-JACK-YOFFS JN)
522    (SETQ JN (1+ JN)))
523  (SETQ LG684-PADDLE-XOFFS (MAKE-ARRAY NIL ART-Q 6)
524        LG684-PADDLE-YOFFS (MAKE-ARRAY NIL ART-Q 6))
525  (SETQ JN 0
526        DX 0) 
527  (DOTIMES (JGROUP 3)
528    (AS-1 DX LG684-PADDLE-XOFFS JN)
529    (AS-1 LG684-DECCNY LG684-PADDLE-YOFFS JN)
530    (SETQ JN (1+ JN)
531          DX (+ DX LG684-DECX1))
532    (AS-1 DX LG684-PADDLE-XOFFS JN)
533    (AS-1 LG684-DECCNY LG684-PADDLE-YOFFS JN)
534    (SETQ JN (1+ JN)
535          DX (+ DX LG684-DECX2))))
536
537(DEFUN LG684-GETLOC (STR BEG LIM &AUX C VAL-LIST IDX)
538  (IF (NULL BEG) (SETQ BEG 0))
539  (IF (NULL LIM) (SETQ LIM (ARRAY-ACTIVE-LENGTH STR)))
540  (MULTIPLE-VALUE (C VAL-LIST IDX)
541    (LNPARSE '("P#-#(P#-#)" "P#-#(#)" "P#-#" "P#@#-#(#)" "P#@#-#" "PL#" "J#-#")
542             STR BEG LIM))
543  (SELECTQ C
544    (0 (SETQ VAL-LIST (CDDDR VAL-LIST)) ;flush adaptor cruft
545       (SI:DESTRUCTURING-BIND (LET NUM PIN) VAL-LIST
546                              (DPB LET LG684-%DIPG
547                                   (DPB NUM LG684-%DIPS
548                                        (DPB PIN CTEST-%%PIN 0)))))
549    (1 (SI:DESTRUCTURING-BIND (LET NUM IGNORE PIN) VAL-LIST
550                              (DPB LET LG684-%DIPG
551                                   (DPB NUM LG684-%DIPS
552                                        (DPB PIN CTEST-%%PIN 0)))))
553    (2 (SI:DESTRUCTURING-BIND (LET NUM PIN) VAL-LIST
554                              (DPB LET LG684-%DIPG
555                                   (DPB NUM LG684-%DIPS
556                                        (DPB PIN CTEST-%%PIN 0)))))
557    (3 (SI:DESTRUCTURING-BIND (LET NUM IGNORE IGNORE PIN) VAL-LIST
558                              (DPB LET LG684-%DIPG
559                                   (DPB NUM LG684-%DIPS
560                                        (DPB PIN CTEST-%%PIN 0)))))
561    (4 (SI:DESTRUCTURING-BIND (LET NUM IGNORE PIN) VAL-LIST
562                              (DPB LET LG684-%DIPG
563                                   (DPB NUM LG684-%DIPS
564                                        (DPB PIN CTEST-%%PIN 0)))))
565    (5 (SI:DESTRUCTURING-BIND (LET PADDLE-LET PADDLE-SIDE) VAL-LIST
566                              (DPB LET LG684-%CONN
567                                   (DPB (+ (LSH (CTEST-DEC-LETTER-TO-NUMBER PADDLE-LET) 1)
568                                           (1- PADDLE-SIDE))
569                                        CTEST-%%PIN
570                                        0))))   ;LG684-%CONT => 0
571    (6 (SI:DESTRUCTURING-BIND (J-NUM PIN) VAL-LIST
572                              (DPB J-NUM LG684-%CONN
573                                   (DPB PIN CTEST-%%PIN
574                                        (DPB 1 LG684-%CONT 0))))))
575)
576
577(DEFUN LG684-MAPLOC (LOC)   ;returns x and y, but swap these to get tester coords
578  (prog (x y group conn pin slot offset)
579        (setq group (ldb LG684-%DIPG loc)
580              conn  (ldb LG684-%CONN loc)
581              pin   (ldb ctest-%%pin loc))
582        (setq y 0 x 0)
583        (cond ((zerop conn)
584               (if (> group LG684-NGRPS)
585                   (ferror nil "group number too high ~s" group))
586               (setq slot (ldb LG684-%DIPS loc)
587                     offset (ldb LG684-%DIPOF loc))
588               (setq x LG684-XGRPOF y LG684-YGRPOF)
589               (setq x (+ x (* (1- slot) LG684-XDIPSP)
590                          (ar-1 twenty-pin-socket-xoff (1- pin)))
591                     y (+ y (* (- 6 group) LG684-YDIPSP)
592                              (ar-1 twenty-pin-socket-yoff (1- pin)))))
593              ((ZEROP (LDB LG684-%CONT LOC))    ;DEC edge connector
594               (IF (OR (ZEROP CONN)
595                       (NOT (<= CONN LG684-MAXCON)))
596                   (FERROR NIL "bad conn number"))
597               (SETQ X (+ X (AR-1 LG684-PADDLE-XOFFS (1- CONN))
598                          (* LG684-DCPNSP (LSH PIN -1)))
599                     Y (+ Y (AR-1 LG684-PADDLE-YOFFS (1- CONN))
600                          (* LG684-DCPINO (LOGAND PIN 1)))))
601              (t (let ((maxp (ar-1 lg684-jacksz conn)))
602                   (if (> pin maxp) (ferror nil "PIN NUMBER TOO HIGH"))
603                   (setq x (+ x (ar-1 (ar-1 flat-cable-conn-xoffs maxp) (1- pin))
604                              (AR-1 LG684-JACK-XOFFS CONN))
605                         y (+ y (ar-1 (ar-1 flat-cable-conn-yoffs maxp) (1- pin))
606                              (AR-1 LG684-JACK-YOFFS CONN)))
607                   )))
608        (return x y)))
609
610
611(DEFUN CTEST-NUMBER-TO-DEC-LETTER (NUM)
612  (IF (>= NUM #/G) (SETQ NUM (1+ NUM)))
613  (IF (>= NUM #/I) (SETQ NUM (1+ NUM)))
614  (IF (>= NUM #/O) (SETQ NUM (1+ NUM)))
615  (IF (>= NUM #/Q) (SETQ NUM (1+ NUM)))
616  (+ #/@ NUM))
617
618(DEFUN CTEST-DEC-LETTER-TO-NUMBER (NUM)
619  (COND ((MEMQ NUM '(#/G #/I #/O #/Q))
620         (FERROR NIL "~C invalid DEC letter" NUM)))
621  (IF (> NUM #/Q) (SETQ NUM (1- NUM)))
622  (IF (> NUM #/O) (SETQ NUM (1- NUM)))
623  (IF (> NUM #/I) (SETQ NUM (1- NUM)))
624  (IF (> NUM #/G) (SETQ NUM (1- NUM)))
625  NUM)
626
627;---
628
629(DEFVAR CTEST-LINES NIL)
630(DEFVAR CTEST-RUNS NIL)
631(DEFVAR CTEST-BAD-RUNS NIL)
632(DEFVAR CTEST-FILE NIL)
633
634(DEFUN CTEST-READIN (&OPTIONAL (FILE "CADRWD;ICMEM3 WLR")
635                               (SKIP-COUNT 0)
636                               (READ-COUNT 2000000))
637  (LET ((STREAM (OPEN FILE '(IN))))
638     (SETQ CTEST-LINES (CTEST-READLINES STREAM SKIP-COUNT READ-COUNT))
639     (CLOSE STREAM))
640 (FORMAT T "~%Readin completed, parsing runs")
641 (SETQ CTEST-RUNS (CTEST-PARSE-RUNS CTEST-LINES))
642 (SETQ CTEST-RUNS (APPEND CTEST-RUNS NIL))
643 (FORMAT T "~%Parse completed, starting phase 1 sort. Total travel =~D"
644         (CTEST-TOTAL-TRAVEL CTEST-RUNS))
645 (SETQ CTEST-RUNS (SORT CTEST-RUNS (FUNCTION RUN-LEFT-PROBE-X-LOCN-<)))
646 (FORMAT T "~%Starting phase 2 sort. Total travel =~D"
647         (CTEST-TOTAL-TRAVEL CTEST-RUNS))
648 (SETQ CTEST-RUNS (CTEST-SORT CTEST-RUNS))
649 (FORMAT T "~%Final total travel ~D" (CTEST-TOTAL-TRAVEL CTEST-RUNS)))
650
651(DEFUN CTEST-PROCESS-WLR (FILE &OPTIONAL (SKIP-COUNT 0) (ALREADY-IN NIL))
652  (SETQ CTEST-FILE FILE)
653  (COND ((NULL ALREADY-IN)
654         (CTEST-READIN FILE)))
655  (CTEST-TRY-TESTING SKIP-COUNT)
656  (CTEST-WRITE-BAD-RUNS "RG;LOSERS >" CTEST-BAD-RUNS 'END)
657)
658
659(DEFUN CTEST-WRITE-BAD-RUNS (FILE BAD PLACE)
660  (LET ((STREAM (OPEN FILE '(OUT))))
661    (FORMAT STREAM "~%PROCESSING ~A RN ~D~%" CTEST-FILE PLACE)
662    (GRIND-TOP-LEVEL BAD 80. STREAM)
663    (CLOSE STREAM)))
664
665(DEFUN CTEST-READ-BAD-RUNS (FILE)
666  (LET ((STREAM (OPEN FILE)))
667    (READLINE STREAM)
668    (READLINE STREAM)
669    (SETQ CTEST-BAD-RUNS (READ STREAM))
670    (CLOSE STREAM)))
671
672;RETEST BAD RUNS.  NOTE THEY ARE IN TEXT FORM
673(DEFUN CTEST-RETEST-BAD-RUNS (&OPTIONAL (BAD-RUNS CTEST-BAD-RUNS))
674  (CTEST-TRY-TESTING 0 (MAPCAR (FUNCTION CTEST-UNCONVERT-RUN)
675                               (MAPCAR (FUNCTION CAR) BAD-RUNS))))
676
677(DEFUN CTEST-FIND-RUN-ENDING (STRING-LOC &OPTIONAL (RUNS CTEST-RUNS))
678  (PROG (LOC L RN)
679        (SETQ LOC (CTEST-GETLOC STRING-LOC)
680              L RUNS
681              RN 0)
682     L  (COND ((NULL L) (RETURN NIL))
683              ((OR (= LOC (CAR (CADR (CAR L))))
684                   (= LOC (CAR (LAST (CADR (CAR L))))))
685               (RETURN RN L)))
686        (SETQ L (CDR L) RN (1+ RN))
687        (GO L)))
688
689(DEFUN CTEST-FIND-RUN-CONTAINING (STRING-LOC &OPTIONAL (RUNS CTEST-RUNS))
690  (PROG TOP (LOC L RN)
691        (SETQ LOC (CTEST-GETLOC STRING-LOC)
692              L RUNS
693              RN 0)
694     L  (COND ((NULL L) (RETURN NIL)))
695        (DOLIST (LK (CADR (CAR L)))
696          (COND ((= LOC LK)
697                 (RETURN-FROM TOP RN L))))
698        (SETQ L (CDR L) RN (1+ RN))
699        (GO L)))
700
701(DEFUN CTEST-FIND-RUN (RUN-NAME &OPTIONAL (RUNS CTEST-RUNS))
702  (PROG (L RN)
703        (SETQ RN 0 L RUNS)
704     L  (COND ((NULL L) (RETURN NIL))
705              ((EQUAL RUN-NAME (CAAR L))
706               (RETURN RN L)))
707        (SETQ RN (1+ RN) L (CDR L))
708        (GO L)))
709
710(defun ctest-try-testing (&optional (skip-count 0) (runs ctest-runs))
711  (prog (l rn wins losses)
712        (setq runs (nthcdr skip-count runs))
713        (setq l runs rn skip-count wins 0 losses nil)
714     l  (cond ((null l)
715               (return wins losses)))
716        (let ((run (car l)))
717          (cond ((> (length (cadr run)) 1)
718                 (cond ((test-wire (car run) (car (cadr run)) (car (last (cadr run))))
719                        (setq wins (1+ wins))
720                        (tv:beep))
721                       (t (setq losses (cons run losses))
722                          (SETQ CTEST-BAD-RUNS (CONS (CTEST-TEST-SEGMENTS RUN)
723                                                     CTEST-BAD-RUNS))
724                          (CTEST-WRITE-BAD-RUNS "RG; CTEST PLACE" CTEST-BAD-RUNS RN))))))
725        (setq l (cdr l))
726        (setq rn (1+ rn))
727        (go l)))
728
729(DEFUN CTEST-TEST-SEGMENTS (RUN)
730  (PROG (LOC-LIST ANS SEG-NO)
731        (SETQ LOC-LIST (CADR RUN) SEG-NO 0)
732   L    (COND ((NULL (CDR LOC-LIST))
733               (RETURN (LIST (CTEST-CONVERT-RUN RUN) ANS)))
734              ((TEST-WIRE (LIST (CAR RUN) (SETQ SEG-NO (1+ SEG-NO)))
735                          (CAR LOC-LIST)
736                          (CADR LOC-LIST))
737               (TV:BEEP))
738              (T (SETQ ANS (CONS (LIST (CTEST-LOC (CAR LOC-LIST))
739                                       (CTEST-LOC (CADR LOC-LIST)))
740                                 ANS))))
741        (SETQ LOC-LIST (CDR LOC-LIST))
742        (GO L)))
743               
744(DEFUN RUN-LEFT-PROBE-X-LOCN-< (R1 R2 &AUX R1X1 R1Y1 R1X2 R1Y2 R2X1 R2Y1 R2X2 R2Y2)
745  (MULTIPLE-VALUE (R1Y1 R1X1) (CTEST-MAPLOC (CAR (CADR R1))))
746  (MULTIPLE-VALUE (R1Y2 R1X2) (CTEST-MAPLOC (CAR (LAST (CADR R1)))))
747  (COND ((< R1X1 R1X2)          ;left probe takes wire with greater X
748         (SETQ R1X1 (PROG1 R1X2 (SETQ R1X2 R1X1)))
749         (SETQ R1Y1 (PROG1 R1Y2 (SETQ R1Y2 R1Y1)))))
750  (MULTIPLE-VALUE (R2Y1 R2X1) (CTEST-MAPLOC (CAR (CADR R2))))
751  (MULTIPLE-VALUE (R2Y2 R2X2) (CTEST-MAPLOC (CAR (LAST (CADR R2)))))
752  (COND ((< R2X1 R2X2)          ;left probe takes wire with greater X
753         (SETQ R2X1 (PROG1 R2X2 (SETQ R2X2 R2X1)))
754         (SETQ R2Y1 (PROG1 R2Y2 (SETQ R2Y2 R2Y1)))))
755  (< R1X1 R2X1))
756
757(DEFUN RUN-LEFT-PROBE-Y-LOCN-< (R1 R2 &AUX R1X1 R1Y1 R1X2 R1Y2 R2X1 R2Y1 R2X2 R2Y2)
758  (MULTIPLE-VALUE (R1Y1 R1X1) (CTEST-MAPLOC (CAR (CADR R1))))
759  (MULTIPLE-VALUE (R1Y2 R1X2) (CTEST-MAPLOC (CAR (LAST (CADR R1)))))
760  (COND ((< R1X1 R1X2)          ;left probe takes wire with greater X
761         (SETQ R1X1 (PROG1 R1X2 (SETQ R1X2 R1X1)))
762         (SETQ R1Y1 (PROG1 R1Y2 (SETQ R1Y2 R1Y1)))))
763  (MULTIPLE-VALUE (R2Y1 R2X1) (CTEST-MAPLOC (CAR (CADR R2))))
764  (MULTIPLE-VALUE (R2Y2 R2X2) (CTEST-MAPLOC (CAR (LAST (CADR R2)))))
765  (COND ((< R2X1 R2X2)          ;left probe takes wire with greater X
766         (SETQ R2X1 (PROG1 R2X2 (SETQ R2X2 R2X1)))
767         (SETQ R2Y1 (PROG1 R2Y2 (SETQ R2Y2 R2Y1)))))
768  (< R1Y1 R2Y1))
769 
770(DEFUN CTEST-TOTAL-TRAVEL (&OPTIONAL (RUNS CTEST-RUNS) (SEGMENTS 10000000))
771  (PROG (X1 X2 Y1 Y2 CR ANS P RX1 RY1 RX2 RY2 DIST)
772        (SETQ ANS 0 P RUNS)
773        (COND ((NULL P) (RETURN ANS)))
774        (SETQ CR (CAR P))
775        (MULTIPLE-VALUE (Y1 X1) (CTEST-MAPLOC (CAR (CADR CR))))
776        (MULTIPLE-VALUE (Y2 X2) (CTEST-MAPLOC (CAR (LAST (CADR CR)))))
777        (COND ((< X1 X2)                ;left probe takes wire with greater X
778               (SETQ X1 (PROG1 X2 (SETQ X2 X1)))
779               (SETQ Y1 (PROG1 Y2 (SETQ Y2 Y1)))))
780        (SETQ P (CDR P))
781    L   (COND ((OR (< (SETQ SEGMENTS (1- SEGMENTS)) 0)
782                   (NULL P))
783               (RETURN ANS)))
784        (SETQ CR (CAR P))
785        (MULTIPLE-VALUE (RY1 RX1) (CTEST-MAPLOC (CAR (CADR CR))))
786        (MULTIPLE-VALUE (RY2 RX2) (CTEST-MAPLOC (CAR (LAST (CADR CR)))))
787        (COND ((< RX1 RX2)
788               (SETQ RX1 (PROG1 RX2 (SETQ RX2 RX1)))
789               (SETQ RY1 (PROG1 RY2 (SETQ RY2 RY1)))))
790        (SETQ DIST (+ (ABS (- RX1 X1)) (ABS (- RY1 Y1))
791                      (ABS (- RX2 X2)) (ABS (- RY2 Y2))))
792        (SETQ X1 RX1 Y1 RY1 X2 RX2 Y2 RY2)
793        (SETQ ANS (+ ANS DIST))
794        (SETQ P (CDR P))
795        (GO L)))
796
797(DEFUN CTEST-SEGMENT-TRAVEL (R1 R2)
798  (PROG (X1 X2 Y1 Y2 RX1 RY1 RX2 RY2)
799        (MULTIPLE-VALUE (Y1 X1) (CTEST-MAPLOC (CAR (CADR R1))))
800        (MULTIPLE-VALUE (Y2 X2) (CTEST-MAPLOC (CAR (LAST (CADR R1)))))
801        (COND ((< X1 X2)                ;left probe takes wire with greater X
802               (SETQ X1 (PROG1 X2 (SETQ X2 X1)))
803               (SETQ Y1 (PROG1 Y2 (SETQ Y2 Y1)))))
804        (MULTIPLE-VALUE (RY1 RX1) (CTEST-MAPLOC (CAR (CADR R2))))
805        (MULTIPLE-VALUE (RY2 RX2) (CTEST-MAPLOC (CAR (LAST (CADR R2)))))
806        (COND ((< RX1 RX2)
807               (SETQ RX1 (PROG1 RX2 (SETQ RX2 RX1)))
808               (SETQ RY1 (PROG1 RY2 (SETQ RY2 RY1)))))
809        (RETURN (+ (ABS (- RX1 X1)) (ABS (- RY1 Y1))
810                   (ABS (- RX2 X2)) (ABS (- RY2 Y2))))))
811
812(DEFUN CTEST-N-OPTIMIZE (N &OPTIONAL (RUNS CTEST-RUNS))
813  (PROG (LP L)
814        (SETQ LP (VALUE-CELL-LOCATION 'RUNS) L (LENGTH RUNS))
815   L    (COND ((NULL (CDR LP)) (RETURN RUNS)))
816        (RPLACD LP (COND ((<= L N)
817                          (CTEST-PERMUTE (CDR LP)))
818                         (T
819                           (NCONC (CTEST-PERMUTE (FIRSTN N (CDR LP)))
820                                  (NTHCDR N (CDR LP))))))
821        (SETQ LP (CDR LP) L (1- L))
822        (GO L)
823))
824
825(DEFUN CTEST-DIF (RL1 RL2)
826  (PROG (C)
827        (SETQ C 0)
828    L   (COND ((OR (NULL RL1) (NULL RL2)
829                   (NOT (EQUAL (CAR RL1) (CAR RL2))))
830               (RETURN C)))
831        (SETQ C (1+ C) RL1 (CDR RL1) RL2 (CDR RL2))
832        (GO L)))
833
834;FIRST FROB IS STARTING POINT, LAST ENDING POINT, SO ACTUAL PERMUTATION IS
835; ON N-2 FROBS.
836(DEFUN CTEST-PERMUTE (SEG)
837   (PROG (BSF BSF-DIST P1 P2 DIST P2-DIST TRY TRY-RESULT TRY-DIST)
838         (COND ((NULL (CDR SEG)) (RETURN SEG 0))
839               ((NULL (CDDR SEG)) (RETURN SEG (CTEST-SEGMENT-TRAVEL (CAR SEG) (CADR SEG))))
840               ((NULL (CDDDR SEG)) (RETURN SEG (+ (CTEST-SEGMENT-TRAVEL (CAR SEG)
841                                                                        (CADR SEG))
842                                                  (CTEST-SEGMENT-TRAVEL (CADR SEG)
843                                                                        (CADDR SEG))))))
844         (SETQ P1 (CAR SEG) SEG (CDR SEG))
845         (DOTIMES (C (1- (LENGTH SEG)))
846           (SETQ P2 (NTH C SEG))
847           (SETQ P2-DIST (CTEST-SEGMENT-TRAVEL P1 P2))
848           (COND ((OR (NULL BSF-DIST)
849                      (< P2-DIST BSF-DIST))
850                  (MULTIPLE-VALUE (TRY-RESULT TRY-DIST)
851                    (CTEST-PERMUTE (SETQ TRY (CONS P2 (BUTNTH C SEG)))))
852                  (SETQ DIST (+ TRY-DIST P2-DIST))
853                  (COND ((OR (NULL BSF-DIST)
854                             (< DIST BSF-DIST))
855                         (SETQ BSF TRY-RESULT BSF-DIST DIST))))))
856         (RETURN (CONS P1 BSF) BSF-DIST)))
857
858;RANDOMIZE, LEAVING FIRST AND LAST THE SAME.
859(DEFUN CTEST-RANDOMIZE (RUNS &AUX N C FIRST LAST MIDDLE)
860  (SETQ FIRST (CAR RUNS) LAST (CAR (LAST RUNS)) MIDDLE (BUTLAST (CDR RUNS)))
861  (SETQ N (LENGTH MIDDLE))
862  (DOTIMES (X N)
863    (SETQ C (RANDOM N))
864    (SETQ MIDDLE (CONS (NTH C MIDDLE) (BUTNTH C MIDDLE))))
865  (NCONC (LIST FIRST) MIDDLE (LIST LAST)))
866
867(DEFUN BUTNTH (N LST)
868  (NCONC (FIRSTN N LST) (NTHCDR (1+ N) LST)))
869
870;CHOOSE A WIRE AT RANDOM (THE FIRST ONE ACTUALLY).  THEN FIND THE WIRE THAT
871; CAN BE TESTED WITH THE LEAST PROBE MOVEMENT, ETC.
872(DEFUN CTEST-SORT (RUNS)
873  (PROG (ANS P CR X1 Y1 X2 Y2 OR RX1 RY1 RX2 RY2 DIST PP LPP BSF BSF-LPP BSF-DIST TEM
874         WC)
875        (SETQ ANS (APPEND RUNS NIL))
876        (SETQ P ANS)            ;FIRST ELEM P POINTS AT CONSIDERED SORTED. REST NOT.
877    L0  (COND ((NULL P)
878               (RETURN ANS)))
879        (SETQ CR (CAR P))
880        (MULTIPLE-VALUE (Y1 X1) (CTEST-MAPLOC (CAR (CADR CR))))
881        (MULTIPLE-VALUE (Y2 X2) (CTEST-MAPLOC (CAR (LAST (CADR CR)))))
882        (COND ((< X1 X2)                ;left probe takes wire with greater X
883               (SETQ X1 (PROG1 X2 (SETQ X2 X1)))
884               (SETQ Y1 (PROG1 Y2 (SETQ Y2 Y1)))))
885        (SETQ LPP P PP (CDR P) BSF NIL BSF-LPP NIL)
886        (SETQ WC 0)
887    L   (COND ((NULL PP)
888               (GO GOBBLE)))
889        (SETQ OR (CAR PP))
890        (MULTIPLE-VALUE (RY1 RX1) (CTEST-MAPLOC (CAR (CADR OR))))
891        (MULTIPLE-VALUE (RY2 RX2) (CTEST-MAPLOC (CAR (LAST (CADR OR)))))
892        (COND ((< RX1 RX2)
893               (SETQ RX1 (PROG1 RX2 (SETQ RX2 RX1)))
894               (SETQ RY1 (PROG1 RY2 (SETQ RY2 RY1)))))
895        (SETQ DIST (+ (ABS (- RX1 X1)) (ABS (- RY1 Y1))
896                      (ABS (- RX2 X2)) (ABS (- RY2 Y2))))
897        (COND ((OR (NULL BSF)
898                   (< DIST BSF-DIST))
899               (SETQ BSF OR BSF-LPP LPP BSF-DIST DIST)))
900        (COND ((AND BSF (OR (> (SETQ WC (1+ WC)) 50.)
901                            (> (ABS (- RX1 X1))
902                               BSF-DIST)))  ;CANT FIND A BETTER ONE
903               (GO GOBBLE)))
904        (SETQ LPP PP PP (CDR PP))
905        (GO L)
906 GOBBLE (COND (BSF-LPP
907                (SETQ TEM (CDR BSF-LPP))        ;SAVE PNTR TO THIS GUY
908                (RPLACD BSF-LPP (CDDR BSF-LPP)) ;SPLICE HIM OUT
909                (RPLACD TEM (CDR P))            ;UNSORTED TAIL
910                (COND ((EQ P TEM) (BREAK FOO T)))
911                (RPLACD P TEM)))                ;ADD TO SORTED PART
912        (SETQ P (CDR P))
913        (GO L0)
914))
915
916
917(DEFUN CTEST-READLINES (STREAM &OPTIONAL (SKIP-COUNT 0) (READ-COUNT 100000))
918  (PROG (P V TEM)
919        (DOTIMES (C SKIP-COUNT)         ;FLUSH THOSE
920          (COND ((EQ (SETQ TEM (READLINE STREAM 'EOF)) 'EOF)
921                 (RETURN NIL)))
922          (RETURN-ARRAY TEM))
923        (SETQ P (VALUE-CELL-LOCATION 'V))
924    L   (COND ((OR (< (SETQ READ-COUNT (1- READ-COUNT)) 0)
925                   (EQ (SETQ TEM (READLINE STREAM 'EOF)) 'EOF))
926               (RETURN V)))
927        (RPLACD P (SETQ P (LIST TEM)))
928        (GO L)))
929
930(DEFUN CTEST-UNCONVERT-RUN (RUN)
931  (LIST (CAR RUN) (MAPCAR (FUNCTION CTEST-GETLOC) (CADR RUN))))
932
933(DEFUN CTEST-CONVERT-RUN (RUN)
934  (LIST (CAR RUN) (MAPCAR (FUNCTION CTEST-LOC) (CADR RUN))))
935 
936(DEFUN CTEST-PRINT-RUNS (&OPTIONAL (RUNS CTEST-RUNS))
937  (DOLIST (RUN RUNS)
938    (PRINT (CTEST-CONVERT-RUN RUN))))
939
940(DEFUN CTEST-PARSE-RUNS (LINES)
941  (PROG (PTR RUN-NAME TYPE SYM LOC CURRENT-RUN RUNS RUNP)
942        (SETQ PTR LINES
943              RUNP (VALUE-CELL-LOCATION 'RUNS))
944    L0  (IF (NULL PTR) (FERROR NIL "unable to find runs part of wlr file"))
945        (MULTIPLE-VALUE (TYPE SYM LOC) (CTEST-LINE-TYPE (CAR PTR)))
946        (SETQ PTR (CDR PTR))
947        (IF (NEQ TYPE 'PAGE-HEADER) (GO L0))
948        (IF (NOT (STRING-EQUAL (CAR PTR) "SIGNAL NAME" 0 0 11. 11.))
949            (GO L0))
950    L   (COND ((NULL PTR) (RETURN RUNS)))
951        (MULTIPLE-VALUE (TYPE SYM LOC) (CTEST-LINE-TYPE (CAR PTR)))
952        (COND ((EQ TYPE 'RUN-HEADER)
953               (SETQ RUN-NAME SYM)
954               (SETQ CURRENT-RUN (NCONC CURRENT-RUN (LIST LOC))))
955              ((EQ TYPE 'RUN-NAME)
956               (SETQ RUN-NAME SYM))
957              ((EQ TYPE 'RUN-ITEM)
958               (SETQ CURRENT-RUN (NCONC CURRENT-RUN (LIST LOC))))
959              ((EQ TYPE 'BLANK)
960               (COND (CURRENT-RUN
961                       (RPLACD RUNP (SETQ RUNP (LIST (LIST RUN-NAME CURRENT-RUN))))))
962               (SETQ CURRENT-RUN NIL)))
963        (SETQ PTR (CDR PTR))
964        (GO L)))
965;Returns line type:
966; RUN-HEADER starts with signal name, followed by pin number
967; RUN-NAME  starts with signal name, then nothing else at all.
968;           Wirelister puts this out when signal name is too long.
969; RUN-ITEM   blank first field, followed by pin number
970; RANDOM     non-null, but unable to make sense out of it
971; BLANK  (completely blank, or starts with 2 tabs)
972
973(DEFUN CTEST-LINE-TYPE (LINE)
974  (PROG (LEN CH SYM IDX LOC)
975        (SETQ IDX 0)
976        (COND ((OR (ZEROP (SETQ LEN (ARRAY-ACTIVE-LENGTH LINE)))
977                   (AND (> LEN 1)
978                        (= (AR-1 LINE 0) #\TAB)
979                        (= (AR-1 LINE 1) #\TAB)))
980               (RETURN 'BLANK) )
981              ((= (SETQ CH (AR-1 LINE IDX)) #\FORM)
982               (RETURN 'PAGE-HEADER))
983              ((AND (< CH 128.)
984                    (NOT (= CH #\SPACE)))
985               (MULTIPLE-VALUE (SYM IDX)
986                 (CTEST-GETSYL LINE IDX '(#\TAB)))  ;SPACE CAN BE PART OF SIG NAME
987               (COND ((OR (= IDX LEN)
988                          (AND (< (+ IDX 4) LEN)        ;"NC" IS FOLLOWED BY A BUNCH OF TABS!
989                               (= (AR-1 LINE IDX) #\TAB)
990                               (= (AR-1 LINE (1+ IDX)) #\TAB)
991                               (= (AR-1 LINE (+ 2 IDX)) #\TAB)
992                               (= (AR-1 LINE (+ 3 IDX)) #\TAB)))
993                      (RETURN 'RUN-NAME SYM NIL)))))
994        (COND ((AND (= (AR-1 LINE IDX) #\TAB)
995                    (SETQ LOC (CTEST-GETLOC LINE (1+ IDX))))
996               (RETURN (COND (SYM 'RUN-HEADER)
997                             (T 'RUN-ITEM))
998                       SYM
999                       LOC)))
1000        (RETURN 'RANDOM)
1001 ))
1002
1003(DEFUN CTEST-GETSYL (STRING IDX &OPTIONAL (TERMS '(#\SPACE #\TAB)))
1004  (PROG (CH LIM FIN)
1005        (SETQ LIM (ARRAY-ACTIVE-LENGTH STRING))
1006    L0  (COND ((NOT (< IDX LIM))
1007               (RETURN NIL IDX))
1008              ((MEMQ (SETQ CH (AR-1 STRING IDX)) TERMS)
1009               (SETQ IDX (1+ IDX))
1010               (GO L0)))
1011        (SETQ FIN (1+ IDX))
1012    L1  (COND ((OR (NOT (< FIN LIM))
1013                   (MEMQ (SETQ CH (AR-1 STRING FIN)) TERMS))
1014               (RETURN (NSUBSTRING STRING IDX FIN) FIN)))
1015        (SETQ FIN (1+ FIN))
1016        (GO L1)))
1017
1018(ctest-conn-and-socket-init)
1019(lg684-init)
Note: See TracBrowser for help on using the repository browser.