A style question
in [Lisp]
|
From: Ken Tilton on 28 Feb 2007 08:03 Tim Bradshaw wrote: > On Feb 28, 2:02 am, job-271842...(a)craigslist.org wrote: > > >>1) In "ANSI Common Lisp", Graham makes the following comments: >> "The loop macro was originally designed to help inexperienced Lisp >>users write iterative code...Unfortunately, loop is more like English >>than its designers ever intended...to understand it in the abstract is >>almost impossible...For such reasons, the use of loop cannot be >>recommended." > > > Reading Paul Graham is a bit like reading reviews of films by a good > critic: he is almost always wrong about everything, but has > interesting things to say and it's possible to reliably predict > whether you'll like something from what he says about it (though often > you will differ from him on whether you like it, due to the above- > mentioned almost-always-being-wrong thing). He's kind of the Barry > Norman of Lisp, really. > > >> Is this a minority view? One of the things that attracted me to Lisp >>was the simplicity, consistency, etc. of the language, so when I read >>the above, it seemed reasonable. > > > Simplicity? consistency? I think you're thinking of some other > language there. CL is this vast industrial thing full of enormous > machines, oil and rust. Some compartments are full of water, and no > one knows what some of the machines do, if anything. Many parts of it > use a mixture of Whitworth & BSF threads (some left-handed), though > much has now been converted to BA or metric, sometimes by use of taps > & dies, sometimes with a hammer. > > CL's closest living relative is FORTRAN: always remember that. > > Incidentally, I'm deeply disappointed in the quality of answers in > this thread. In the elder days there would have been at least a few > followups showing how to do this in the proper "FORMAT string > indistinguishable from line noise" way. Oh, absolutely, long overdue in this thread. Is this going to become a lost art? The village elders need to step up, methinks. I started playing with it, but I am just an elder, not a Lisp elder. Screams for a nested thingy, yes? > No true CL programmer ever > uses any other construct when the problem can be solved with a > combination of FORMAT, LOOP & GO (FORMAT being always preferable, > obviously). There may yet be those reading cll who know this, though > I suspect they have all gone into the west now. Well, I did not want to get morbid, but that is what I was thinking. As Lisp reaches fifty we can expect to see its legends start scrolling off the top of the screen. kt -- Well, I've wrestled with reality for 35 years, Doctor, and I'm happy to state I finally won out over it. -- Elwood P. Dowd In this world, you must be oh so smart or oh so pleasant. -- Elwood's Mom
From: Ken Tilton on 28 Feb 2007 08:06 Rainer Joswig wrote: > In article <1172658813.746823.247380(a)p10g2000cwp.googlegroups.com>, > "Tim Bradshaw" <tfb+google(a)tfeb.org> wrote: >>Incidentally, I'm deeply disappointed in the quality of answers in >>this thread. In the elder days there would have been at least a few >>followups showing how to do this in the proper "FORMAT string >>indistinguishable from line noise" way. No true CL programmer ever >>uses any other construct when the problem can be solved with a >>combination of FORMAT, LOOP & GO (FORMAT being always preferable, >>obviously). There may yet be those reading cll who know this, though >>I suspect they have all gone into the west now. > > > It is always a shock to me when I look at such code. I mean > many pages long functions full of GOs, two letter variables > and such (and zero comments). I cannot > believe that humans can write this code. You refer of course to the Cello code to create a 3-D oblong button of variable thickness with rounded corners of variable radius: (defun ix-render-oblong (lbox thickness baser slices stacks) (unless slices (setq slices 0)) (unless stacks (setq stacks (if (zerop thickness) 0 (min 10 (max 1 ;; force 3d if nonzero thickness (round (abs thickness) 2)))))) (when (eql (abs thickness) (abs baser)) (setf thickness (* .99 thickness))) (trc nil "oblong" baser thickness etages) (loop with theta = (/ pi 2 slices) with etages = stacks ;; french floors (etages) zero = ground floor with lw/2 = (/ (r-width lbox) 2) with lh/2 = (/ (r-height lbox) 2) with bx = (- lw/2 baser) with by = (- lh/2 baser) for etage upto etages for oe = 0 then ie for ie = (unless (= etage etages) (* (/ (1+ etage) etages) (/ pi 2))) for ii = (if (not ie) 0 ;; throwaway value to avoid forever testing if nil (+ (* (abs thickness) (- 1 (cos ie))))) for ox = lw/2 then ix for oy = lh/2 then iy for oz = 0 then iz for oc = (cornering baser slices) then ic for ic = (when ie (cornering (- baser ii) slices)) for ix = (- lw/2 ii) for iy = (- lh/2 ii) for iz = (when ie (* thickness (sin ie))) do (trc nil "staging" etage ie) (gl-translatef (+ (r-left lbox) lw/2)(+ (r-bottom lbox) lh/2) 0) (with-gl-begun ((if ie gl_quad_strip gl_polygon)) (loop for (dx dy no-turn-p) in '((1 1)(-1 1)(-1 -1)(1 -1)(1 1 t)) ;;for dbg = (and (eql dx 1)(eql dy 1)(not no-turn-p)) do (destructuring-bind (xyn0 ix0 iy0 ox0 oy0) (cons (+ (if oc (/ theta 2) 0) (ecase dx (1 (ecase dy (1 0)(-1 (/ pi -2)))) (-1 (ecase dy (1 (/ pi 2))(-1 pi))))) (if oc (case (* dx dy) (1 (list (* dx ix)(* dy by)(* dx ox)(* dy by))) (-1 (list (* dx bx)(* dy iy)(* dx bx)(* dy oy)))) (list (* dx ix)(* dy iy)(* dx ox)(* dy oy)))) ;; --- lay-down start/only ------------- (when ie (ogl-vertex-normaling ie xyn0 ix0 iy0 iz)) (ogl-vertex-normaling oe xyn0 ox0 oy0 oz) (trc nil "cornering!!!!!!----------------" dx dy) ;; --- corner if slices and not just finishing strip (unless no-turn-p (trc nil "------ start ------------------" (length oc)(length ic)) (loop for (oxn . oyn) in oc for icrem = ic then (cdr icrem) for (ixn . iyn) = (car icrem) for xyn upfrom (+ xyn0 theta) by theta do (macrolet ((vtx (elev gx sx gy sy gz) `(progn (when (minusp (* dx dy)) (rotatef ,sx ,sy)) (ogl-vertex-normaling ,elev xyn (incf ,gx (* dx ,sx)) (incf ,gy (* dy ,sy)) ,gz)))) (trc nil "ocn icn" oxn oyn (car icrem)) (when icrem (vtx ie ix0 ixn iy0 iyn iz)) (vtx oe ox0 oxn oy0 oyn oz))))))) (gl-translatef (- (+ (r-left lbox) lw/2)) (- (+ (r-bottom lbox) lh/2)) 0))) > I always > think the author was some ugly 'Terminator' from the future, > though lately the Terminators seem to be blond and good looking. Actually I was doing a rare transcription from a paper solution (where short variables saved pencil lead). kt -- Well, I've wrestled with reality for 35 years, Doctor, and I'm happy to state I finally won out over it. -- Elwood P. Dowd In this world, you must be oh so smart or oh so pleasant. -- Elwood's Mom
From: Rainer Joswig on 28 Feb 2007 08:48 In article <C7fFh.6$M24.0(a)newsfe12.lga>, Ken Tilton <kentilton(a)gmail.com> wrote: > Rainer Joswig wrote: > > In article <1172658813.746823.247380(a)p10g2000cwp.googlegroups.com>, > > "Tim Bradshaw" <tfb+google(a)tfeb.org> wrote: > > >>Incidentally, I'm deeply disappointed in the quality of answers in > >>this thread. In the elder days there would have been at least a few > >>followups showing how to do this in the proper "FORMAT string > >>indistinguishable from line noise" way. No true CL programmer ever > >>uses any other construct when the problem can be solved with a > >>combination of FORMAT, LOOP & GO (FORMAT being always preferable, > >>obviously). There may yet be those reading cll who know this, though > >>I suspect they have all gone into the west now. > > > > > > It is always a shock to me when I look at such code. I mean > > many pages long functions full of GOs, two letter variables > > and such (and zero comments). I cannot > > believe that humans can write this code. > > You refer of course to the Cello code to create a 3-D oblong button of > variable thickness with rounded corners of variable radius: This code is harmless. It is not even UPPERCASE. Not enough global variables. Scroll down! > > (defun ix-render-oblong (lbox thickness baser slices stacks) > (unless slices (setq slices 0)) > (unless stacks (setq stacks (if (zerop thickness) > 0 (min 10 > (max 1 ;; force 3d if nonzero > thickness > (round (abs thickness) 2)))))) > (when (eql (abs thickness) (abs baser)) > (setf thickness (* .99 thickness))) > (trc nil "oblong" baser thickness etages) > > (loop > with theta = (/ pi 2 slices) > with etages = stacks ;; french floors (etages) zero = ground floor > with lw/2 = (/ (r-width lbox) 2) > with lh/2 = (/ (r-height lbox) 2) > with bx = (- lw/2 baser) > with by = (- lh/2 baser) > for etage upto etages > for oe = 0 then ie > for ie = (unless (= etage etages) > (* (/ (1+ etage) etages) > (/ pi 2))) > for ii = (if (not ie) > 0 ;; throwaway value to avoid forever testing if nil > (+ (* (abs thickness) > (- 1 (cos ie))))) > > for ox = lw/2 then ix > for oy = lh/2 then iy > for oz = 0 then iz > for oc = (cornering baser slices) then ic > for ic = (when ie > (cornering (- baser ii) slices)) > for ix = (- lw/2 ii) > for iy = (- lh/2 ii) > for iz = (when ie > (* thickness (sin ie))) > > do (trc nil "staging" etage ie) > > > (gl-translatef (+ (r-left lbox) lw/2)(+ (r-bottom lbox) lh/2) 0) > > (with-gl-begun ((if ie > gl_quad_strip > gl_polygon)) > > (loop for (dx dy no-turn-p) > in '((1 1)(-1 1)(-1 -1)(1 -1)(1 1 t)) > ;;for dbg = (and (eql dx 1)(eql dy 1)(not no-turn-p)) > do (destructuring-bind (xyn0 ix0 iy0 ox0 oy0) > (cons (+ (if oc (/ theta 2) 0) > (ecase dx (1 (ecase dy (1 0)(-1 (/ pi -2)))) > (-1 (ecase dy (1 (/ pi 2))(-1 pi))))) > (if oc > (case (* dx dy) > (1 (list (* dx ix)(* dy by)(* dx ox)(* dy by))) > (-1 (list (* dx bx)(* dy iy)(* dx bx)(* dy > oy)))) > (list (* dx ix)(* dy iy)(* dx ox)(* dy oy)))) > > ;; --- lay-down start/only ------------- > (when ie > (ogl-vertex-normaling ie xyn0 ix0 iy0 iz)) > (ogl-vertex-normaling oe xyn0 ox0 oy0 oz) > > (trc nil "cornering!!!!!!----------------" dx dy) > ;; --- corner if slices and not just finishing strip > > (unless no-turn-p > (trc nil "------ start ------------------" (length > oc)(length ic)) > (loop for (oxn . oyn) in oc > for icrem = ic then (cdr icrem) > for (ixn . iyn) = (car icrem) > for xyn upfrom (+ xyn0 theta) by theta > do (macrolet > ((vtx (elev gx sx gy sy gz) > `(progn > (when (minusp (* dx dy)) > (rotatef ,sx ,sy)) > (ogl-vertex-normaling ,elev xyn > (incf ,gx (* dx ,sx)) > (incf ,gy (* dy ,sy)) > ,gz)))) > (trc nil "ocn icn" oxn oyn (car icrem)) > (when icrem > (vtx ie ix0 ixn iy0 iyn iz)) > (vtx oe ox0 oxn oy0 oyn oz))))))) > (gl-translatef (- (+ (r-left lbox) lw/2)) > (- (+ (r-bottom lbox) lh/2)) 0))) > > > I always > > think the author was some ugly 'Terminator' from the future, > > though lately the Terminators seem to be blond and good looking. > > Actually I was doing a rare transcription from a paper solution (where > short variables saved pencil lead). > > kt Take this (not written by me). Well, actually there are too many comments. Though I'm not sure if they actually would help to understand the code... (DEFUN INCREMENTAL-SEARCH (REVERSE-P) (INITIALIZE-INCREMENTAL-SEARCH-GLOBALS) (SELECT-WINDOW *WINDOW*) ;Flush typeout before TYPEIN-LINE-ACTIVATE (TYPEIN-LINE "") ;Necessary if in the mini-buffer (UNWIND-PROTECT (TYPEIN-LINE-ACTIVATE (SI:WITH-STACK-ARRAY ;; Allocate an skip-table on the stack to avoid consing too much. ;; We don't bother with the reoccurrence table because (1) it's size ;; changes for each pattern string, and (2) it's small anyway. (SKIP-RESOURCE (HIGHEST-LEGAL-CHAR-CODE) :TYPE 'ART-FIXNUM) (PROG (CHAR ; The current command. REAL-CHAR ; The one to :UNTYI if need be XCHAR ; Upcase version of character MUST-REDIS ; T => The echo-area must be completely redisplayed. (P 0) ; The stack pointer into *IS-BP*, etc. for input and rubout (P1 0) ; The pointer for which search we are doing. ; Can never exceed P. SUPPRESSED-REDISPLAY ; T if the last input char was read before ; redisplay had a chance to finish. ; A G read that way acts like a failing search quit. (BP (POINT)) ; The POINT. BP1 ; Aux BP used for actual searching. NEW-BP TIME-OUT ; Set by SEARCH when it times out so we can check input. INPUT-DONE ; An altmode or control char has been seen. ; Do not look for input any more; just search, then exit. (ORIG-PT) ; Original position of POINT. (SKIP-TABLE NIL) (OLD-SKIP-TABLE NIL) (REOCCURRENCE-TABLE NIL) (OLD-REOCCURRENCE-TABLE NIL) ) (SETQ ORIG-PT (COPY-BP BP)) (SETQ BP1 (COPY-BP BP)) ; This is reused to save consing. (STORE-ARRAY-LEADER 0 *IS-STRING* 0); Clear out the search string. (ASET T *IS-STATUS* 0) ; Initialize the stacks. (ASET REVERSE-P *IS-REVERSE-P* 0) (ASET ':NORMAL *IS-OPERATION* 0) (ASET 0 *IS-POINTER* 0) (ASET (COPY-BP BP) *IS-BP* 0) (SETQ MUST-REDIS T) ; Initially we must redisplay. (GO CHECK-FOR-INPUT) ;; Come here if there is input, or nothing to do until there is input. INPUT (SETQ SUPPRESSED-REDISPLAY NIL) (AND (WINDOW-READY-P *WINDOW*) ;In case of minibuffer (REDISPLAY *WINDOW* ':POINT)) ; Redisplay point position while waiting. (OR (= (WINDOW-REDISPLAY-DEGREE *WINDOW*) DIS-NONE) (SETQ SUPPRESSED-REDISPLAY T)) (MULTIPLE-VALUE (CHAR REAL-CHAR) (EDITOR-INPUT :SCROLL T :MOUSE :RETURN :ANY-TYI 'COMMAND)) ; allow the mouse to work! (UNLESS (CHARACTERP CHAR) ; eliminate mouse clicks now (SETQ INPUT-DONE T) ;; This is admittedly a kludge, but it's the simplest way to ;; get EDITOR-INPUT to execute the mouse-clicked command (SETQ *YANKED-MINI-BUFFER-COMMAND* CHAR) (GO CHECK-FOR-INPUT)) (SETQ XCHAR (CHAR-UPCASE CHAR)) (COND ((NOT (OR (NOT (ZEROP (CHAR-BITS CHAR))) (CHAR-EQUAL CHAR #\ALTMODE) (CHAR-EQUAL CHAR #\END) (CHAR-EQUAL CHAR #\RUBOUT) (CHAR-EQUAL CHAR #\CLEAR-INPUT) (CHAR-EQUAL CHAR #\HELP) (CHAR-EQUAL CHAR #\SCROLL) (MEM #'CHAR-EQUAL CHAR TV:KBD-INTERCEPTED-CHARACTERS))) (GO NORMAL)) ((MEMQ XCHAR '(#\c-S #\c-R)) (PUSH-ISEARCH-STATUS) (ASET ':REPEAT *IS-OPERATION* P) (LET ((NEW-REVERSE-P (CHAR= XCHAR #\c-R))) (COND ;; In reverse mode, just go to forward. ((NEQ (AREF *IS-REVERSE-P* P) NEW-REVERSE-P) (ASET NEW-REVERSE-P *IS-REVERSE-P* P) (SETQ MUST-REDIS T) (ASET ':REVERSE *IS-OPERATION* P)) ((ZEROP (AREF *IS-POINTER* P)) (LET ((STRING (STRING (OR (CAAR *SEARCH-RING*) (BARF))))) (IF *RUBOUT-KILLS-LAST-SEARCH-STRING* (PROGN (COPY-ARRAY-CONTENTS STRING *IS-STRING*) (ASET (ARRAY-ACTIVE-LENGTH STRING) *IS-POINTER* P)) (LOOP FOR MORE FIRST NIL THEN T FOR CHAR BEING THE ARRAY-ELEMENTS OF STRING WHEN MORE DO (PUSH-ISEARCH-STATUS) DO (LET ((IDX (AREF *IS-POINTER* P))) (AND ( IDX (ARRAY-LENGTH *IS-STRING*)) (ADJUST-ARRAY-SIZE *IS-STRING* (+ IDX 100))) (ASET CHAR *IS-STRING* IDX) (ASET (1+ IDX) *IS-POINTER* P)) (ASET ':NORMAL *IS-OPERATION* P)))) (SETQ MUST-REDIS T)))) (GO CHECK-FOR-INPUT)) ((CHAR= XCHAR #\c-Q) (SETQ CHAR (MAKE-CHAR (EDITOR-INPUT))) (GO NORMAL)) ((CHAR= XCHAR #\c-G) (COND ((AND (OR SUPPRESSED-REDISPLAY (NEQ (AREF *IS-STATUS* P) T)) (PLUSP P)) ;; G in other than a successful search ;; rubs out until it becomes successful. (SETQ P (DO ((P (1- P) (1- P))) ((EQ (AREF *IS-STATUS* P) T) P))) (SETQ P1 (MIN P P1) MUST-REDIS T) (GO CHECK-FOR-INPUT)) (T (MOVE-POINT (AREF *IS-BP* 0)) (FUNCALL *TYPEIN-WINDOW* ':MAKE-COMPLETE) (RETURN NIL)))) ((MEMQ CHAR TV:KBD-INTERCEPTED-CHARACTERS) (ZWEI-KBD-INTERCEPT-CHARACTER CHAR *TYPEIN-WINDOW*) (GO CHECK-FOR-INPUT)) ((OR (CHAR= CHAR #\ALTMODE) (CHAR= CHAR #\END)) (AND (ZEROP P) (RETURN (LET ((*CURRENT-COMMAND* 'COM-STRING-SEARCH)) (COM-STRING-SEARCH-INTERNAL REVERSE-P NIL NIL NIL)))) (SETQ INPUT-DONE T) (GO CHECK-FOR-INPUT)) ((CHAR= CHAR #\RUBOUT) (COND (( P 0) ; If he over-rubbed out, (BEEP) ; that is an error. (GO CHECK-FOR-INPUT)) (T ;; Rubout pops all of these PDLs. (SETQ P (1- P)) (SETQ P1 (MIN P P1)) (SETQ MUST-REDIS T) (GO CHECK-FOR-INPUT)))) ((CHAR= CHAR #\CLEAR-INPUT) (SETQ P 0 P1 0 MUST-REDIS T) (GO CHECK-FOR-INPUT)) ((CHAR= CHAR #\HELP) (PRINT-DOC ':FULL *CURRENT-COMMAND*) (FORMAT T "~2&Type any character to flush:") (CHECK-FOR-TYPEOUT-WINDOW-TYPEOUT) (GO CHECK-FOR-INPUT)) (T (FUNCALL STANDARD-INPUT ':UNTYI REAL-CHAR) (SETQ INPUT-DONE T) (GO CHECK-FOR-INPUT))) (FERROR NIL "A clause fell through.") ;; Normal chars to be searched for come here. NORMAL (OR MUST-REDIS (TYPEIN-LINE-MORE "~C" CHAR)) (PUSH-ISEARCH-STATUS) (LET ((IDX (AREF *IS-POINTER* P))) (AND ( IDX (ARRAY-LENGTH *IS-STRING*)) (ADJUST-ARRAY-SIZE *IS-STRING* (+ IDX 100))) (WHEN (CHAR-FAT-P CHAR) (UNLESS (STRING-FAT-P *IS-STRING*) (LET ((NEW-STRING (MAKE-ARRAY (ARRAY-LENGTH *IS-STRING*) :FILL-POINTER (FILL-POINTER *IS-STRING*) :TYPE 'ART-FAT-STRING))) (COPY-ARRAY-CONTENTS *IS-STRING* NEW-STRING) (STRUCTURE-FORWARD *IS-STRING* NEW-STRING 2 2) (SETQ *IS-STRING* NEW-STRING)))) (ASET CHAR *IS-STRING* IDX) (ASET (1+ IDX) *IS-POINTER* P)) (ASET ':NORMAL *IS-OPERATION* P) ;; Come here after possibly processing input to update the search tables ;; to search for a while. First, if necessary and not suppressed ;; update the search string displayed in the echo area. CHECK-FOR-INPUT ;; If there is input available, go read it. ;; Otherwise, do work if there is work to be done. (AND (NOT INPUT-DONE) (FUNCALL STANDARD-INPUT ':LISTEN) (GO INPUT)) ;; Now do some work for a while, then go back to CHECK-FOR-INPUT. (COND (MUST-REDIS (SETQ MUST-REDIS NIL) (TYPEIN-LINE "~:|") (OR (AREF *IS-STATUS* P1) (TYPEIN-LINE-MORE "Failing ")) (AND (AREF *IS-REVERSE-P* P) (TYPEIN-LINE-MORE "Reverse ")) (TYPEIN-LINE-MORE "I-Search: ") (STORE-ARRAY-LEADER (AREF *IS-POINTER* P) *IS-STRING* 0) (TYPEIN-LINE-MORE "~A" *IS-STRING*))) ;; Now see what sort of state the actual search is in, and ;; what work there is to do. P1 points at the level of the ;; table on which we are actually working. (MOVE-BP BP1 (AREF *IS-BP* P1)) ;; Display point at the end of the last search level which has succeeded. (DO ((P0 P1 (1- P0))) ((EQ (AREF *IS-STATUS* P0) T) (MOVE-POINT (AREF *IS-BP* P0)))) (MUST-REDISPLAY *WINDOW* DIS-BPS) (COND ((EQ (AREF *IS-STATUS* P1) ':GO) ;; If we are about to repeat a search, generate the Boyer-Moore ;; tables for the pattern string and cache them. Do not generate ;; the tables if they are already cached. (IF (OR TIME-OUT (CHAR= XCHAR #\c-S)) (WHEN (AND (NULL OLD-SKIP-TABLE) (NULL OLD-REOCCURRENCE-TABLE)) (SETQ OLD-SKIP-TABLE (GENERATE-BOYER-SKIP-TABLE *IS-STRING* SKIP-RESOURCE) OLD-REOCCURRENCE-TABLE (GENERATE-BOYER-REOCCURRENCE-TABLE *IS-STRING*))) (SETQ OLD-SKIP-TABLE NIL OLD-REOCCURRENCE-TABLE NIL)) ;; We need an additional check here, because of the interaction between ;; additional c-S'es and typeahead. If you type, say "FEPFS" c-S in a ;; long buffer with "FEP" at the beginning of the buffer and "FEPFS" at ;; the end of the buffer, then *IS-STRING* can get out of sync with the ;; reoccurrence table. This code gets them back in sync. (WHEN (AND OLD-REOCCURRENCE-TABLE ( (ARRAY-LENGTH OLD-REOCCURRENCE-TABLE) (STRING-LENGTH *IS-STRING*))) (SETQ OLD-SKIP-TABLE (GENERATE-BOYER-SKIP-TABLE *IS-STRING* SKIP-RESOURCE) OLD-REOCCURRENCE-TABLE (GENERATE-BOYER-REOCCURRENCE-TABLE *IS-STRING*))) (SETQ SKIP-TABLE OLD-SKIP-TABLE REOCCURRENCE-TABLE OLD-REOCCURRENCE-TABLE) ;; If the level we were working on is still not finished, ;; search at most 100 more lines. If we find it or the end of the buffer ;; before then, this level is determined and we can work on the next. ;; Otherwise, we remain in the :GO state and do 100 more lines next time. (MULTIPLE-VALUE (NEW-BP TIME-OUT) (SEARCH BP1 *IS-STRING* (AREF *IS-REVERSE-P* P1) NIL 100 NIL *ALPHABETIC-CASE-AFFECTS-SEARCH* ;--- SKIP-TABLE REOCCURRENCE-TABLE)) ;; What happened? (COND (TIME-OUT ;; Nothing determined. NEW-BP has where we stopped. (MOVE-BP BP1 NEW-BP)) ((NULL NEW-BP) ;; This search was determined to be a failure. (OR (AND (MEMQ ':MACRO-ERROR (FUNCALL STANDARD-INPUT ':WHICH-OPERATIONS)) (FUNCALL STANDARD-INPUT ':MACRO-ERROR)) (BEEP)) (ASET NIL *IS-STATUS* P1) (MOVE-BP BP1 (AREF *IS-BP* (1- P1))) (MOVE-POINT BP1) (SETQ MUST-REDIS T)) (T ;; This search level has succeeded. (ASET T *IS-STATUS* P1) (MOVE-POINT NEW-BP) (MOVE-BP BP1 NEW-BP)))) (( P P1) ;; This level is finished, but there are more pending levels typed ahead. (SETQ P1 (1+ P1)) (ASET (SETQ BP1 (COPY-BP BP1)) *IS-BP* P1) (STORE-ARRAY-LEADER (AREF *IS-POINTER* P1) *IS-STRING* 0) (COND ((NULL (AREF *IS-STATUS* (1- P1))) (COND ((NEQ (AREF *IS-OPERATION* P1) ':REVERSE) ;; A failing search remains so unless we reverse direction. (ASET NIL *IS-STATUS* P1)) (T ;; If we reverse direction, change prompt line. (SETQ MUST-REDIS T)))) ((EQ (AREF *IS-OPERATION* P1) ':NORMAL) ;; Normal char to be searched for comes next. ;; We must adjust the bp at which we start to search ;; so as to allow the user to extend the string already found. (MOVE-BP BP1 (FORWARD-CHAR BP1 (COND ((AREF *IS-REVERSE-P* P1) (COND ((= (ARRAY-ACTIVE-LENGTH *IS-STRING*) 1) 0) (T (ARRAY-ACTIVE-LENGTH *IS-STRING*)))) (T (- 1 (ARRAY-ACTIVE-LENGTH *IS-STRING*)))) T))))) ;; If there is nothing left to do, and terminator seen, exit. (INPUT-DONE (SEARCH-RING-PUSH ;; Entries on the search ring should have a leader (STRING-NCONC (MAKE-ARRAY (ARRAY-ACTIVE-LENGTH *IS-STRING*) ':TYPE (ARRAY-TYPE *IS-STRING*) ':FILL-POINTER 0) *IS-STRING*) 'SEARCH) (TYPEIN-LINE-MORE "~C" #\END) (MAYBE-PUSH-POINT ORIG-PT) (SELECT-WINDOW *WINDOW*) (RETURN NIL)) ;; Nothing to do and no terminator, wait for input. (T (GO INPUT))) (GO CHECK-FOR-INPUT) ))) (FUNCALL *MODE-LINE-WINDOW* ':DONE-WITH-MODE-LINE-WINDOW)) DIS-BPS) How about this? This is clearly from aliens. (DEFMFUN MEVAL1 (FORM) (declare (special nounl *break-points* *break-step*)) (COND ((ATOM FORM) (PROG (VAL) (COND ((NOT (SYMBOLP FORM)) (RETURN FORM)) ((AND $NUMER (SETQ VAL (SAFE-MGET FORM '$NUMER)) (OR (NOT (EQ FORM '$%E)) $%ENUMER)) (RETURN (MEVAL1 VAL))) ((NOT (BOUNDP FORM)) (IF (SAFE-GET FORM 'BINDTEST) (MERROR "~:M unbound variable" FORM) (RETURN FORM))) ((MFILEP (SETQ VAL (SYMBOL-VALUE FORM))) (SETQ VAL (EVAL (DSKGET (CADR VAL) (CADDR VAL) 'VALUE NIL))))) (WHEN (AND $REFCHECK (MEMQ FORM (CDR $VALUES)) (NOT (MEMQ FORM REFCHKL))) (SETQ REFCHKL (CONS FORM REFCHKL)) (MTELL "~:M has value.~%" FORM)) (RETURN VAL))) ((OR (AND (ATOM (CAR FORM)) (SETQ FORM (CONS (NCONS (CAR FORM)) (CDR FORM)))) (ATOM (CAAR FORM))) (LET ((BAKTRCL BAKTRCL) TRANSP) (PROG (U ARYP) (declare (special aryp)) ;;(COND ((EQ DEBUG '$ALL) (SETQ BAKTRCL (CONS FORM BAKTRCL)))) (setq *last-meval1-form* form) (SETQ ARYP (MEMQ 'array (CDAR FORM))) (COND ((AND (NOT OPEXPRP) (NOT ARYP) (MEMQ (CAAR FORM) '(MPLUS MTIMES MEXPT MNCTIMES))) (GO C)) ;; dont bother pushing mplus and friends on baktrcl ;; should maybe even go below aryp. ((AND debug (PROGN ;(SETQ BAKTRCL (CONS FORM BAKTRCL)) ;; if wanting to step, the *break-points* ;; variable will be set to a vector (possibly empty). (when (and *break-points* (or (null *break-step*) (null (funcall *break-step* form)))) (let ((ar *break-points*)) (declare (type (vector t) ar)) (sloop for i below (fill-pointer ar) when (eq (car (aref ar i)) form) do (*break-points* form) (loop-finish)))) NIL))) ((AND $SUBSCRMAP ARYP (DO ((X (MARGS FORM) (CDR X))) ((OR (NULL X) (MXORLISTP (CAR X))) X))) (SETQ NOEVALARGS NIL) (RETURN (SUBGEN FORM))) ((EQ (CAAR FORM) 'MQAPPLY) (RETURN (MQAPPLY1 FORM)))) (BADFUNCHK (CAAR FORM) (CAAR FORM) NIL) A (SETQ U (OR (SAFE-GETL (CAAR FORM) '(NOUN)) (AND NOUNSFLAG (EQ (GETCHAR (CAAR FORM) 1) '%) (NOT (OR (GETL-FUN (CAAR FORM) '(SUBR FSUBR LSUBR)) (SAFE-GETL (CAAR FORM) '(MFEXPR* MFEXPR*S)))) (PROG2 ($VERBIFY (CAAR FORM)) (SAFE-GETL (CAAR FORM) '(NOUN)))) (AND (NOT ARYP) $TRANSRUN (SETQ TRANSP (OR (SAFE-MGETL (CAAR FORM) '(T-MFEXPR)) (SAFE-GETL (CAAR FORM) '(TRANSLATED-MMACRO))))) (AND (NOT ARYP) (SETQ U (OR (SAFE-MGET (CAAR FORM) 'TRACE) (AND $TRANSRUN (SAFE-GET (CAAR FORM) 'TRANSLATED) (NOT (SAFE-MGET (CAAR FORM) 'LOCAL-FUN)) (SETQ TRANSP T) (CAAR FORM)))) (GETL-FUN U '(EXPR SUBR LSUBR))) (COND (ARYP (SAFE-MGETL (CAAR FORM) '(HASHAR ARRAY))) ((SAFE-MGETL (CAAR FORM) '(MEXPR MMACRO))) ((SAFE-MGETL (CAAR FORM) '(T-MFEXPR))) (T (OR (SAFE-GETL (CAAR FORM) '(MFEXPR* MFEXPR*S)) (GETL-FUN (CAAR FORM) '(SUBR FSUBR EXPR FEXPR macro LSUBR))))))) (COND ((NULL U) (GO B)) ((AND (MEMQ (CAR U) '(MEXPR MMACRO)) (MFILEP (CADR U))) (SETQ U (LIST (CAR U) (DSKGET (CADADR U) (CAR (CDDADR U)) (CAR U) NIL)))) ((AND (MEMQ (CAR U) '(ARRAY HASHAR)) (MFILEP (CADR U))) (I-$UNSTORE (NCONS (CAAR FORM))) (RETURN (MEVAL1 FORM)))) (RETURN (COND ((EQ (CAR U) 'HASHAR) (HARRFIND (CONS (CAR FORM) (MEVALARGS (CDR FORM))))) ((MEMQ (CAR U) '(FEXPR FSUBR)) (IF FEXPRERRP (MERROR "Attempt to call ~A ~A from MACSYMA level.~ ~%Send a bug note." (CAR U) (CAAR FORM))) (SETQ NOEVALARGS NIL) (APPLY (CAAR FORM) (CDR FORM))) ((OR (AND (EQ (CAR U) 'SUBR) (PROG2 (MARGCHK (CAAR FORM) (CDR FORM)) T)) (EQ (CAR U) 'LSUBR)) ; ((MEMQ (CAR U) '(SUBR LSUBR)) ; (MARGCHK (CAAR FORM) (CDR FORM))) (APPLY (CAAR FORM) (MEVALARGS (CDR FORM)))) ((EQ (CAR U) 'NOUN) ; (MARGCHK (CAAR FORM) (CDR FORM)) (COND ((OR (MEMQ (CAAR FORM) NOUNL) NOUNSFLAG) (SETQ FORM (CONS (CONS (CADR U) (CDAR FORM)) (CDR FORM))) (GO A)) (ARYP (GO B)) ((MEMQ (CAAR FORM) '(%SUM %PRODUCT)) (SETQ U (DO%SUM (CDR FORM) (CAAR FORM)) NOEVALARGS NIL) (CONS (NCONS (CAAR FORM)) U)) (T (MEVAL2 (MEVALARGS (CDR FORM)) FORM)))) ((EQ (CAR U) 'array) (ARRFIND (CONS (CAR FORM) (MEVALARGS (CDR FORM))))) ((EQ (CAR U) 'MEXPR) (MLAMBDA (CADR U) (CDR FORM) (CAAR FORM) NOEVALARGS form)) ((MEMQ (CAR U) '(MMACRO TRANSLATED-MMACRO)) (SETQ NOEVALARGS NIL) (MEVAL (MMACRO-APPLY (CADR U) FORM))) ((EQ (CAR U) 'MFEXPR*) (SETQ NOEVALARGS NIL) (APPLY (CADR U) (NCONS FORM))) #+cl ((eq (car u) 'macro) (setq noevalargs nil) (setq form (cons(caar form) (cdr form))) ; (setf (car form) (caar form) ) (eval form) ) #+Maclisp ((EQ (CAR U) 'MFEXPR*S) (SETQ NOEVALARGS NIL) ;; use macsyma Trace if you want to trace this call. (SUBRCALL T (CADR U) FORM)) ((EQ (CAR U) 'T-MFEXPR) (APPLY (CADR U) (CDR FORM))) (T (MARGCHK (CAAR FORM) (CDR FORM)) (APPLY (CADR U) (MEVALARGS (CDR FORM)))))) B #+(OR PDP10 Multics Franz NIL cl) (IF (AND (NOT ARYP) (LOAD-FUNCTION (CAAR FORM) T)) (GO A)) (BADFUNCHK (CAAR FORM) (CAAR FORM) NIL) (IF (SYMBOLP (CAAR FORM)) (SETQ U (BOUNDP (CAAR FORM))) (RETURN (MEVAL1-EXTEND FORM))) C (COND ((OR (NULL U) (AND (SAFE-GET (CAAR FORM) 'OPERATORS) (NOT ARYP)) (EQ (CAAR FORM) (SETQ U (SYMBOL-VALUE (CAAR FORM))))) (SETQ FORM (MEVAL2 (MEVALARGS (CDR FORM)) FORM)) (RETURN (OR (AND (SAFE-MGET (CAAR FORM) 'ATVALUES) (AT1 FORM)) FORM))) ((AND ARYP (SAFE-GET (CAAR FORM) 'NONARRAY)) (RETURN (CONS (CONS (CAAR FORM) ARYP) (MEVALARGS (CDR FORM))))) ((ATOM U) (BADFUNCHK (CAAR FORM) U NIL) (SETQ FORM (CONS (CONS (GETOPR U) ARYP) (CDR FORM))) (GO A)) ((EQ (CAAR U) 'LAMBDA) (IF ARYP (MERROR "Improper array call") (RETURN (MLAMBDA U (CDR FORM) (CAAR FORM) NOEVALARGS form)))) (T (RETURN (MAPPLY1 U (MEVALARGS (CDR FORM)) (CAAR FORM) form))))))) (T (MAPPLY1 (CAAR FORM) (MEVALARGS (CDR FORM)) (CAAR FORM) form))))
From: André Thieme on 28 Feb 2007 10:03 job-271842874(a)craigslist.org schrieb: > Another friend of mine commenting on the same FizzBuzz thread supplied > the following Python code. It certainly is concise: > > for i in xrange(1,101): > print(str(i), "Fizz", "Buzz", "FizzBuzz")[(i%3==0)|(i%5==0)<<1] > > Forgive my ignorance, but is anything like the boolean bit shifting > technique used in the Python code above possible in Lisp? No big loss if > it isn't, just curious. In principle you could do exactly that - if you also provide this strange shifting operator: >>> (11%3==0)|(11%5==0) False >>> (12%3==0)|(12%5==0) True >>> (20%3==0)|(20%5==0) True >>> (30%3==0)|(30%5==0) True And: >>> False<<1 0 >>> True<<1 2 Okay, so we expect << to throw out 0, 2, 2 and 2 for the three cases. But: >>> (11%3==0)|(11%5==0)<<1 0 >>> (12%3==0)|(12%5==0)<<1 1 >>> (20%3==0)|(20%5==0)<<1 2 >>> (30%3==0)|(30%5==0)<<1 3 It seems truth values would be structs in Lisp. They not only have a boolean value of t or nil, but they also represent some number. Anyway, let's say you provide <<, then you could say: (loop for i upto 100 do (print (nth (<< (mod i 3) (mod i 5)) (list i "Fizz" "Buzz" "FizzBuzz"))) This version has now a smaller complexity with its 20 tokens as the Python version with its 28 tokens. Okay, if you count the definition of << in Lisp, then Python wins here, because it already is defined there. > I suppose it's unreasonable to expect the Lisp version to be as concise > as the Python version No, it is reasonable. And as you see: Python is complexity wise 40% worse. > - not only is this a toy example, but I think a > language with more syntax will be able to provide more brevity in > certain situations. You are right. For people who are happy to write scripts Python will be an excellent choice. Scripting is the domain of Python and usually it will do very well with 10 line programs. But if we are talking about something that goes beyond 3k LOC things change. Then Lisp will have a more specialized syntax and win. So it is the question of complexity. For easy problems Lisp will most likely not be much better than Python - but probably also not worse. But as complexity grows you are better off with Lisp. > That's a tradeoff I'm willing to accept given the > benefits of a syntax that's more readily parsed and manipulated. Clever choice. Andr� --
From: Richard M Kreuter on 28 Feb 2007 10:40
"Tim Bradshaw" <tfb+google(a)tfeb.org> writes: > Incidentally, I'm deeply disappointed in the quality of answers in > this thread. In the elder days there would have been at least a few > followups showing how to do this in the proper "FORMAT string > indistinguishable from line noise" way. No true CL programmer ever > uses any other construct when the problem can be solved with a > combination of FORMAT, LOOP & GO (FORMAT being always preferable, > obviously). There may yet be those reading cll who know this, though > I suspect they have all gone into the west now. (dotimes (i 100) (format t "~[~[FizzBuzz~:;Fizz~]~:;~[Buzz~:;~D~]~]~%" (mod i 3) (mod i 5) i)) Best I could do on one cup of coffee. -- RmK |