Mercurial > lbo > hg > lispplay
view lists.lisp @ 3:83743e601985 default tip
Add new lisp files
author | Lewin Bormann <lbo@spheniscida.de> |
---|---|
date | Sun, 13 Oct 2019 14:00:24 +0200 |
parents | a3dca97e5f3b |
children |
line wrap: on
line source
;; Reverse list (defun my-reverse (l) (if (= 0 (length l)) '() (append (my-reverse (cdr l)) (list (car l))))) (defun my-foldl (f init l) ;; tail-recursive but not lazy (if l (my-foldl f (funcall f init (car l)) (cdr l)) init)) (defun my-foldr (f l init) ;; lazy but not tail-recursive (if l (funcall f (car l) (my-foldr f (cdr l) init)))) (defun my-map (f l) (if l (cons (funcall f (car l)) (my-map f (cdr l))) nil)) (defun my-mapf (f l) (defun folder (acc e) (cons (funcall f e) acc)) (my-reverse (my-foldl #'folder nil l))) (defun my-range (from to) (defun _my-range (acc from to) ;; for tail recursion (if (eql from to) acc (_my-range (cons to acc) from (- to 1)))) (_my-range () (- from 1) (- to 1))) (defun my-append (a b) ;; not tail-recursive (if a (cons (car a) (my-append (cdr a) b)) b)) (defmacro my-dotimes ((var up-to) &rest body) `(mapcar #'(lambda (,var) ,@body) (my-range 0 ,up-to))) (defmacro my-let (bindings &rest body) (defun _names () (mapcar #'car bindings)) (defun _vals () (mapcar #'cadr bindings)) `(funcall #'(lambda (,@(_names)) ,@body) ,@(_vals))) (defmacro my-let* (bindings &rest body) (if (not bindings) `(funcall (lambda () ,@body)) `(my-let (,(car bindings)) (my-let* ,(cdr bindings) ,@body)))) (defmacro my-if (condition expr-t expr-f) `(or (and ,condition (or ,expr-t t)) ,expr-f)) (defmacro my-looptimes (n &body body) `(let ((i 0)) (tagbody start ,@body (incf i) (unless (eql i ,n) (go start))))) (defmacro my-looplist ((name list) &body body) `(let ((_list ,list)) (tagbody start (let ((,name (pop _list))) ,@body (when _list (go start))) ))) (defun access-nth (list n) (if (= n 1) (car list) (access-nth (cdr list) (1- n)))) (defmacro make-nth-accessor (name n) (let ((list-arg-name (gensym))) `(defun ,name (,list-arg-name) (access-nth ,list-arg-name ,n)))) (make-nth-accessor my-first 1) (make-nth-accessor my-second 2) (make-nth-accessor my-third 3)