Return Styles: Pseud0ch, Terminal, Valhalla, NES, Geocities, Blue Moon. Entire thread

TGA loader in LISP

Name: Anonymous 2010-12-26 3:20

`class` macro automatically generates everything



class Tga

  idLength   = U1  // 00h Size of Image ID field

  cmapType   = U1  // 01h Color map type

  imageType  = U1  // 02h Image type code

  cmapStart  = U2  // 03h Color map origin

  cmapLength = U2  // 05h Color map length

  cmapDepth  = U1  // 07h Depth of color map entries

  xOffset    = U2  // 08h X origin of image

  yOffset    = U2  // 0Ah Y origin of image

  width      = U2  // 0Ch Width of image

  height     = U2  // 0Eh Heigth of image

  bpp        = U1  // 10h Image pixel size

  descriptor = U1  // 11h Image descriptor byte

  idField    = idLength++U1 

  cmap       = cmapLength++U1

  bmap       = (width*height*bpp%8)++U1

Name: Anonymous 2010-12-27 6:42

>>26



(defun checked-incut-match (ob pb chk p bs ps xs cont fail suff)

  (declare (ignorable ob))

    (let* {tail

           n (gensym), e (gensym), l, r (gensym)

           c (gensym), cx (gensym), bt (gensym)

           reset [%do [_set_l n [%cl %|+| n 1]]

                      [c nil]]

           btfn [_fn [] [_if [%cl %|<| n e] reset fail]]

           do-chk #{if chk

                       [%do [%|=:| pb [%|==| l p]]

                            [_if pb

                                 tail

                                 (if $1 [bt] fail)]]

                       tail}}



       (setf l (if chk

                   (if (eql ob %_) (unisym) ob)

                   p))



       (unless (or chk (eql ob %_))

         (setf suff (conc [_let [[ob l]] ] suff)))



       (unless ps ; no need for backtracing

         (setf tail (conc suff (funcall cont bs)))

         (return-from checked-incut-match

           [_let (conc [[l xs]]

                       (if (not (msg? pb)) [[pb nil]]))

              %do (funcall do-chk nil)]))



       (setf tail (conc suff (checked-ltl bs ps r cont [bt])))



       [_let (conc [ [n 0] [e [%len xs]] [c nil] [l nil] [r nil]  ]

                   (if (not (msg? pb)) [[pb nil]]))

         _let [ [bt btfn] ]

           %do [%cont [_fn [cx] [_set_l c cx]]]

               [_set_l l [%take n xs]]

               [_set_l r [%drop n xs]] ; SPEED: move it after l=p check

               ;;[%say l "  " r]

               (funcall do-chk t)

       ]))

Name: Anonymous 2010-12-27 6:45



(defun checked-incut (p bs ps xs cont fail)

  ;; paren-less form

  ;;   ob:pb:@!xs

  ;;   ob:pb:@[l++!f]

  ;; normalized form:

  ;;   @(ob:pb:!xs)

  ;;   @(ob:pb:[l++!f])



  ;; FIXME: pass whole input to user function to get match length

  ;; FIXME: try doing binary search

  (let* (chk    ; dont bind p, just check against bound var

         count

         chk-count

         size-hint

         eb

         pref

         suff

         elt-size

         (p (2nd p))

         (p (1st p)) (ob (2nd p))

         (p (3rd p)) (pb (2nd p))

         (p (3rd p)))

    (when (eql pb %_) (setf pb (unisym)))

    (@list-case p

      (%lst (x)

        (@list-case x

          (%|++| (c e)

            (setf count c)

            (setf p e)

            (@list-case p

              (%|!| (v)

                (setf chk t)

                (when (type-sym? v)

                  (let* ((n (rhd (sym-path v)))

                         (n (st-intern (concatenate 'string "parse"

                                                    (sq-to-string n)))))

                    (setf v n)))

                (setf p   v))

              (else (unless (sym? p)

                      (setf p [%lst p])

                      (setf chk t)))))))

      (%|!| (v)

        (setf chk t)

        (setf p   v)))



    (when chk (setf size-hint (if (sym? p)

                                  (get-parser-input-size p))))



    (unless chk

      (unless (sym? p) (error "`@` cant deincut: ~a" (prn p)))

      (if (fnd p bs)

          (setf chk t)

          (unless (eql p %_)

            (setf bs (pre p bs)))))



    (when count

      ;; FIXME: eb could be constant or bound

      ;; FIXME: allow !count:elem





      (if (eql ob %_) (setf ob (unisym)))



      (setf chk-count (or (not (sym? count)) (fnd count bs)))



      (unless size-hint (setf size-hint 1))

      (unless chk-count (setf size-hint nil))



      (when size-hint

        (setf elt-size size-hint)

        ;; FIXME: move %|*| to pref

        (setf size-hint (if (and (numberp count) (numberp size-hint))

                            (* size-hint count)

                            [%|*| size-hint count])))



      (if (and (not chk) (symbolp p))

          (setf eb p))



      (let* ((es (unisym)))

        (setf p

          (cond

            ((not chk)

             (if chk-count

               (progn

                 [_fn [es] [_if [%|==| [%len es] count]

                                       [%lst es]

                                       nil]])

               (progn

                 (unless (eql count %_)

                   (setf suff (conc [_let [[count [%len pb]]] ] suff)))

                 (if (eql p %_)

                     [_fn [es] [%lst es]]

                     %|_matchDups|))))

            ((and chk-count elt-size)

             [_fn [es] [%|_matchArrayFNS| count elt-size p es]])

            (chk-count

             [_fn [es] [%|_matchArrayFN| count p es]])

            (elt-size

             (unless (eql count %_)

               (setf suff (conc [_let [[count [%len pb]]] ] suff)))

             [_fn [es] [%|_matchArrayFS| elt-size p es]])

            (t

             (unless (eql count %_)

               (setf suff (conc [_let [[count [%len pb]]] ] suff)))

             [_fn [es] [%|_matchArrayF| p es]])

            ))

        (setf suff (conc [_let [[pb [%lhd pb]]] ] suff))

        (setf chk t)

        ))



    (if (eql p %_) (setf p (unisym)))



    ;; FIXME: if size hint gets changed, we are in trouble

    (conc pref

          (if (and size-hint (not (fnd p bs)))

              (checked-parse p ob pb bs ps xs cont fail size-hint suff)

              (checked-incut-match ob pb chk p bs ps xs cont fail suff)))))

Newer Posts

TGA loader in LISP

1 Name: Anonymous 2010-12-26 3:20

27 Name: Anonymous 2010-12-27 6:42

28 Name: Anonymous 2010-12-27 6:45

Name: Anonymous 2010-12-26 3:20

Name: Anonymous 2010-12-27 6:42

Name: Anonymous 2010-12-27 6:45