TGA loader in LISP

`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

Why don't the implementation of the DSL that you wrote in Lisp here so we could actually be able to read your code. It's not possible to know the semantics of random DSL's without seeing the documentation or a reference implementation.

*Why don't you post the implementation

Where are all the parens?

>>2>>3
Code is really dirty and I'm too shy to post it. Besides it would require writing documentation/tutorial and I'm very bad at such things.

>>4
It is a top-level, so no need for excessive parens.

>>14
you seem autistic

>>8
Listen to >>11 and get the fuck out of here, thanks.

>>8,10,14
Get the fuck out.

>>2
>>3
Because there's no code. On the imageboard from whence this amusing person came it feeds us with shopped screenshots of some unearthly REPL at least, but you're not gonna see even those.

>>10
stop hallucinating


class P n=U2 d=n++U2; [p:!P]~>p [2 0 1 2 3 4]"
[n:!U2 d:n++!U2]
Compiling: P
Compiling: p?
Compiling: P.n
Compiling: P.d
Compiling: P.set_n
Compiling: P.set_d
Compiling: parseP
no
[:P n=2 d=(513 1027)]

>>10
I considered that possibility, however some of the code he posted earlier seemed elaborate enough that it might just be something written in a real implementation.

I wrote a similar binary class reader/writer implementation in the past, and i find it pretty comfortable to use, but I'm not one to bother actually making a lexer/parser and giving up the advantages of s-expressions, so my DSL is just S-Exp based and just uses standard CL syntax without any syntax sugar on top.

His language seems to depart a lot from Lisps and just seems to be a language in its own right which is (supposedly) implemented on top of CL. I'm not even sure one has to right to call it a Lisp. For example, if I were to write some O'Caml which is interpreted by an interpreter written in CL, should I say I wrote Lisp, not O'Caml? Or what if I wrote some Python code and ran it with clpython (a Python compiler written in Common Lisp, http://common-lisp.net/project/clpython/), can I really say I wrote Lisp code (even though, I can compile the python code to Lisp, and it would be "Lisp", even if the original is not). Would it be fair to say that you wrote C code when you wrote some Scheme or Haskell code which you then compiled to C code? Or say you wrote x86 asm code when you just took some C code and compiled it to x86 asm?

>>13
Any language based on S-exps is a Lisp.

>>14
However his code does not have S-Exps anymore, so it would be questionable if it can really be called that.
By that logic, I can call everything a Lisp, as one can write a compiler that compiles just about anything to Lisp.

>>15
It has S-Exps, but reader allows defining operators, and most forms are designed in such way, that they dont require parens. Top level also dont require parens, so in 95% cases no parens required.

>>16
For example, following toplevel `let`-form

(let ((a 123)) (let ((b 456)) ...))
can be redesigned as

let (a 123) let (b 456) ...
at expense of implicit progn. But who needs implicit progn anyway?

>>17
But you can no longer write:
(let ((a 123)
      (b 256))
  ...)

Well, jolly good! LISP has far too many redundant parentheses as it is, it could bear with losing a few.

>>18
let should really allow this:
(let (a 123
      b 256
      c (length some-list))
   ...)


Usually when the list of variables is long, I prefer the more parenthesized form, but when you have, in Scheme:
(let ((x '())) ...)
it gets kinda ugly, I'd really like do (let (x '()) ...).

Maybe I'll do a macro for this.

>>20
There's a cheap trick I sometimes use in CL for that when x is a toplevel variable binding: arguments passed to the function can be treated the same as a let form around the function body (at the same time, let can be seen as a lambda form to which you pass some arguments), however there's this difference between Scheme and CL in that argument lists to functions and lambda's, or ordinary lambda lists, to be more precise, allow you to pass other kinds of arguments such as optional arguments, rest arguments (variable number), keyword arguments and "auxiliary" arguments. All, but auxiliary arguments could technically be seen as passing any number of arguments and having a special way of parsing them (this part of CL is quite comfy when you write large programs as it allows for a lot of customization without the programmer needing to change code around, however it comes with added complexity which sometimes means you might have to involve lambda-list parsers in more advanced macros)... Anyway, I got a bit off-topic here, but the other kind of argument, "auxiliary ones" (marked by &aux) are nothing more than a way of introducing a local variable as if it were an argument, or basically adding extra variables without needing to add an extra let form. It also has some uses when it comes to places where you can't quite pass values, but can pass on argument lists (they are rare, but do exist, if you want an example, you could think of structure definition forms). Or to cut things short, if you had something like:
(defun f ()
  (let ((x '())) ...))
you could just write
(defun f (&aux x) ...) instead.
Or (defun f () (let (x) ...)) if you want to take advantage of the extra sugar that comes with CL's let and the fact that in CL NIL and [m]'()[/] are the same

>>21
Thanks, you give me inspiration.
I've done a simple macro that does what I said in >>20
And also a defun macro with an optional "aux:"
(define-syntax (my-let stx)
  (syntax-case stx ()
    ((_ ((x y) ...) b ...)
     #'(let ((x y) ...) b ...))
    ((_ (x y) b ...)
     #'(let ((x y)) b ...))
    ((_ (x ...) b ...)
     #`(let #,(let loop ((xs #'(x ...))
                         (r '()))
                (if (stx-null? xs) (reverse r)
                    (let ((x (stx-car xs)))
                      (cond ((and (stx-pair? x)
                                  (stx-null? (stx-cdr x))) (loop (stx-cdr xs)
                                                                 (cons (list (stx-car x) ''()) r)))
                            ((stx-pair? x) (loop (stx-cdr xs)
                                                 (cons x r)))
                            (else (loop (stx-cdr xs)
                                        (cons (list x ''()) r)))))))
         b ...))
    ((_ x b ...)
     #'(let ((x '())) b ...))))
(define-syntax defun
  (syntax-rules (aux:)
    ((defun f a aux: (x ...) b ...)
     (define f (lambda a (my-let (x ...) b ...))))
    ((defun f a aux: x b ...)
     (define f (lambda a (my-let x b ...))))
    ((defun f a b ...)
     (define f (lambda a b ...)))))
(my-let ((x 2) ; x = 2
         (y) ; y = '()
         z ; z = '()
         )
   (displayln (format "~a~a~a" x y z)))
(my-let (x 2) ; x = 2
   (displayln x))
(my-let x x) ; x = '()
(my-let (x) x) ; same
#;(my-let (x 2 y 2) x) ; this doesn't work, though, I'm too lazy to check wheter it is a valid (let) binding or not.
(my-let ((x 1)
         (y 2)
         (z 3)) ; you can still use it as normal let
    (+ x y z))
(my-let ()
   '())

(defun fun (l)
  aux: x       ; x = '()
  (cons l x))

(fun 2) ; => (2)

(defun f (xs)
  aux: (x y z)
  ;do something here
  )

>>22
Fixed that, now (letn (x 2 y 2) b ...) is the same as (let ((x 2) (y 2)) b ...):

(define-syntax (letn stx)
  (syntax-case stx ()
    ((_ ((x y) ...) b ...)
     #'(let ((x y) ...) b ...))
    ((_ (x ...) b ...)
     #`(let #,(let loop ((xs #'(x ...))
                         (r '()))
                (if (stx-null? xs) (reverse r)
                    (let ((x (stx-car xs)))
                      (cond ((and (stx-pair? x)
                                  (stx-null? (stx-cdr x))) (loop (stx-cdr xs)
                                                                 (cons (list (stx-car x) ''()) r)))
                            ((stx-pair? x) (loop (stx-cdr xs)
                                                 (cons x r)))
                            ((not (or (stx-null? (stx-cdr xs))
                                      (identifier? (stx-cadr xs)))) (loop (stx-cddr xs)
                                                                          (cons (list x (stx-cadr xs)) r)))
                            (else (loop (stx-cdr xs)
                                        (cons (list x ''()) r)))))))
         b ...))
    ((_ x b ...)
     #'(let ((x '())) b ...))))

>>23
And now can fully replace let, you can make named lets:
[code]  (define-syntax (letn stx)
    (let ((help
           (λ (xs) (let loop ((xs xs)
                              (r '()))
                     (if (stx-null? xs) (reverse r)
                         (let ((x (stx-car xs)))
                           (cond ((and (stx-pair? x)
                                       (stx-null? (stx-cdr x))) (loop (stx-cdr xs)
                                                                      (cons (list (stx-car x) ''()) r)))
                                 ((stx-pair? x) (loop (stx-cdr xs)
                                                      (cons x r)))
                                 ((not (or (stx-null? (stx-cdr xs))
                                           (identifier? (stx-cadr xs)))) (loop (stx-cddr xs)
                                                                               (cons (list x (stx-cadr xs)) r)))
                                 (else (loop (stx-cdr xs)
                                             (cons (list x ''()) r))))))))))
      (syntax-case stx ()
        ((_ ((x y) ...) b ...)
         #'(let ((x y) ...) b ...))
        ((_ (x ...) b ...)
         #`(let #,(help #'(x ...))
             b ...))
        ((_ id ((x y) ...) b ...)
         #'(let ((x y) ...) b ...))
        ((_ id (x ...) b ...)
         #`(let id #,(help #'(x ...))
             b ...))
        ((_ x b ...)
         #'(let ((x '())) b ...)))))

(letn loop (i 0 r)
   (if (> i 10) r
       (loop (+ i 1) (cons i r)))) ; => (10 9 8 7 6 5 4 3 2 1 0)
#|
It translates to:
(let loop ((i 0)
           (r '()))
  etc ...)
|#

forgot my [/code]
  (define-syntax (letn stx)
    (let ((help
           (λ (xs) (let loop ((xs xs)
                              (r '()))
                     (if (stx-null? xs) (reverse r)
                         (let ((x (stx-car xs)))
                           (cond ((and (stx-pair? x)
                                       (stx-null? (stx-cdr x))) (loop (stx-cdr xs)
                                                                      (cons (list (stx-car x) ''()) r)))
                                 ((stx-pair? x) (loop (stx-cdr xs)
                                                      (cons x r)))
                                 ((not (or (stx-null? (stx-cdr xs))
                                           (identifier? (stx-cadr xs)))) (loop (stx-cddr xs)
                                                                               (cons (list x (stx-cadr xs)) r)))
                                 (else (loop (stx-cdr xs)
                                             (cons (list x ''()) r))))))))))
      (syntax-case stx ()
        ((_ ((x y) ...) b ...)
         #'(let ((x y) ...) b ...))
        ((_ (x ...) b ...)
         #`(let #,(help #'(x ...))
             b ...))
        ((_ id ((x y) ...) b ...)
         #'(let ((x y) ...) b ...))
        ((_ id (x ...) b ...)
         #`(let id #,(help #'(x ...))
             b ...))
        ((_ x b ...)
         #'(let ((x '())) b ...)))))

(letn loop (i 0 r)
   (if (> i 10) r
       (loop (+ i 1) (cons i r)))) ; => (10 9 8 7 6 5 4 3 2 1 0)
#|
It translates to:
(let loop ((i 0)
           (r '()))
  etc ...)
|#

Bump for the implementation of the DSL

>>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)
       ]))


(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)))))

>>20
Have you looked at Clojure? It has that because the generic map operations work on lists as well.

>>27-28
I've written some damn messy CL code, but yours still beats mine...
Major differences in my style is that I tend to give most important variables a name, so I understand what my code is supposed to be doing.
You seem to have used quite a bit of reader macros in there, yet why not use a with-gensyms-like macro for all those gensyms you're using?

>>30
>I tend to give most important variables a name
Hard to name very generic variables. And I use this `p` var in a hunderd of places, as it is part of this equation-solver interface, so naming it would inflate code beyond believe.

>You seem to have used quite a bit of reader macros in there
Else I would have to write '|st|::|/systemDirectory/_matchArrayFNS|, instead of %|_matchArrayFNS|, and I cant use normal macros, because I need raw symbol before macroexpansion takes place.

>why not use a with-gensyms-like macro
I lost my with-gensyms macro somewhere.

>>31
Ah... that's understandable...

with-gensyms goes something like this (from memory):

(defmacro with-gensyms (names &body body)
  `(let ,(loop for name in names collect `(,name (gensym ,(string name))))
     ,@body))

(with-gensyms (abc def ghj)
  123)

;=> expands to
(let ((abc (gensym "ABC"))
      (def (gensym "DEF"))
      (ghj (gensym "GHJ")))
  123)

NECROBAMPU

Lol, im doing a Warcraft 2 game implementation right now. And LISP is capable of pretty fast graphics blitting.
http://tinypic.com/r/vgo6yr/7

Everything other than blitting and audio decoding I'm going to implement in this little DSL.

>>34
BTW, blitting is 32-bit with alpha blending.

>>34
Started calling it a DSL after that bad copy of FV told him.
Same person and IHBT

>>34
Are you that familiar with the game mechanics to implement it?

>>34
lol warcraft 2 was good.

"WHAT IS IT"
"for the alliance"
etc

>>37
Lisper shouldnt have difficulties implementing a video game.

>>38
I love hand-drawn sprites.

>>39
Lisper shouldnt have difficulties implementing a video game.

Yes, that's why majority of the games is written by lispers.

>>40
http://en.wikipedia.org/wiki/Ignoratio_elenchi

>>41
http://www.fallacyfiles.org/fallfall.html

>>41
majority of the games is
IAYHBTMGF.

>>43
NYJMUA

And then >>40 was aware of Land of Lisp.

bump

Bump for ``in LISP".

Sage for yet more useless Listhp faggortry.

>>48
This isn't really Lisp, ``faggot''

>>49
It is faggotry anyway.