newlisp-utility.lsp

; 2008/12/23 second, third, fourth and labels are added.
;            with-open-file is improved.( setq _stream -> let )
; 2009/ 1/ 6 hayashi is improved. (push used.)
;            gensym, mklist, flat1, mappend are added.
;            with-open-file is improved. (catch and gensym used.)
; 2009/ 1/ 7 mapc,psetq are added.
; 2009/ 1/12 mapc is improved. (nthlst -> (map (curry nth i)))
; 2009/ 1/17 mappend is improved. (function -> macro)
;            maplist is added.
;            reference-inversion is added.
; 2009/ 1/21 read-integer is improved. (remove apostrophe for inc)
; 2009/ 1/26 reference-inversion:reference-inversion is improved. (remove macro-detect)
; 2009/ 1/27 incf & decf are improved. (On Lisp compatible)
; 2009/ 2/18 car is improved. (Common Lisp compatible)
; 2009/ 4/ 7 multi-let is added.
; 2009/ 4/15 read-string is improved. (read-buffer used.)
; 2010/ 6/15 ++ & -- is removed.
; 2010/ 6/16 map-mv is added.
;            null is improved.(using not only)
;            reference-inversion:reference-inversion is improved. (using MAIN:setf in defref)
; 2010/ 6/18 gensym is improved. (no suffix of context)
;            lables is improved. (remove begin in body)
;            ++ & -- are added.
;            consp is improved. (function -> macro)
;            aif is added.
; 2010/ 6/23 mklist is improved. (function -> macro)
; 2010/ 6/24 mappend is improved. (macro -> function)
; 2010/ 7/14 consp is improved. (macro -> function)
; 2010/ 8/ 2 cdr is improved. ((cdr '(a)) -> nil)
; 2010/12/10 curryEx is added.
; 2010/12/17 car, cdr, second, third, fourth are improved. (Common Lisp compatible)
; 

;http://www.alh.net/newlisp/phpbb/viewtopic.php?t=1942&highlight=gensym
;(define (gensym) (sym (string "gs" (uuid))))
(define *gensym*:*gensym* 0)
(define (gensym num)
  (if (number? num)
      (let (res)
        (dotimes (i num)
          (push (sym (string  "gensym" (++ *gensym*:*gensym*))) res -1)))
    (sym (string  "gensym" (++ *gensym*:*gensym*)))))
(global 'gensym)
(context 'MAIN:with-open-file)
(define-macro (with-open-file:with-open-file)
  (letex (_result (gensym)
          _stream (args 0 0)
          _open (cons 'open (1 (args 0)))
          _body (cons 'begin (1 (args))))
    (let ((_stream _open) (_result))
      (catch _body '_result)
      (and _stream (close _stream))
      _result)))

(context 'MAIN:defun)
;http://www.alh.net/newlisp/phpbb/viewtopic.php?t=1064&highlight=defun
(set 'defun:defun
	(lambda-macro (_func-name _arguments)
      (set _func-name (append '(lambda ) (list _arguments) (args)))))

(context 'MAIN:labels)
(define-macro (labels:labels)
  (letex (_labels (append '(begin)
                          (map (fn (x)
                                 (list 'setq (x 0) (append '(fn) (list (x 1)) (2 x))))
                            (args 0))
                          (1 (args))))
    _labels))

(context 'MAIN:hayashi)
(define-macro (hayashi:hayashi)
;  (letex ((_func (flat (list (args 0) '_x (1 (args))))))
  (letex (_func (push '_x (args) 1))
    (fn (_x) _func )))

(context 'MAIN:decf)
;(set 'decf:decf
;  (lambda-macro (_number)
;    (set _number (- (eval _number) 1))))
(define-macro (decf:decf place (val 1))
  (letex (_place place
          _val val)
    (setf _place (- $it _val))))

(context 'MAIN:incf)
;(define-macro (incf:incf)
;  (letex (_number (args 0))
;    (setq _number (+ (eval _number) 1))))
(define-macro (incf:incf place (val 1))
  (letex (_place place
          _val val)
    (setf _place (+ $it _val))))

(context 'MAIN:rsetq)
(define-macro (rsetq:rsetq)
  (letex (_arg (args 0 1)
          _func (args 0))
    (setq _arg _func)))

(context 'MAIN:reference-inversion)
(setq *reference-inversion* nil)
(setq *set* 'reference-inversion:set)

(define-macro (reference-inversion:set expr)
  (letex (_expr expr)
    (if *reference-inversion* '_expr _expr)))

(define-macro (reference-inversion:reference-inversion m)
  (setq *reference-inversion* true)
  (letex (_body (if (and (list? (args 0))
                         ;(macro? (eval (args 0 0)))
                         (ref *set* (eval (args 0 0))))
                    (append (list m (eval (args 0))) (1 (args)))
                  (cons m (args))))
    (begin
      (setq *reference-inversion* nil)
      _body)))

(define-macro (reference-inversion:setf)
  (letex (_body (cons 'begin
                      (map (curry append '(reference-inversion MAIN:setf))
                           (explode (args) 2))))
    (begin
      _body)))

(define-macro (reference-inversion:defref)
  (letex (_mname (args 0))
    (if (ref *set* (eval _mname)) nil
        (MAIN:setf (nth '(1 -1) _mname) (cons *set* (list $it))))))

(context MAIN)

(define cdr    (fn (lst) (and (not (nil? lst)) (or (rest lst) nil))))
(define car    (fn (lst) (first (or lst '(nil)))))
(define second (fn (lst) (car (cdr lst))))
(define third  (fn (lst) (car (cdr (cdr lst)))))
(define fourth (fn (lst) (car (cdr (cdr (cdr lst))))))
(define cadr   second)
(define progn begin)
(define t true)
(define equal =)
(define char-code char)
(define atom atom?)
(define floatp float?)
(define integerp integer?)
(define listp list?)
;(define null (fn (x) (not (true? x))))
(define null not)
(define numberp number?)
(define stringp string?)
(define symbolp symbol?)
(define zerop zero?)

(defun read-integer (bytes INPUT-STREAM)
  (let ((c nil) (value 0) (cnt 0) (base 1))
    (while (and (< cnt bytes) (setq c (read-char INPUT-STREAM)))
      (setq value (+ value (* base c)))
      (setq base (* base 256))
      (inc cnt))
    (if c value nil)))

(defun read-string (bytes INPUT-STREAM)
  (let (buff (dup "00" bytes))
    (read-buffer INPUT-STREAM buff bytes)
    buff))

(defun remove (item seq)
  (cond ((string? seq) (replace item (copy seq) ""))
	(true (replace item (copy seq)))))
(define remove-if clean)
(define remove-if-not filter)

(defun evenp (num)
  (= (& num 1) 0))
(defun oddp (num)
  (= (& num 1) 1))
(define (consp L) (and (list? L) (true? L)))
(defun flat1 (lst)
  (apply append (map mklist lst)))
(defun mappend ()
  (apply append (apply map (args))))
(defun mapc (f)
 (let (lsts (args))
  (dotimes (i (apply min (map length lsts)))
    (apply f (map (curry nth i) lsts)))))
(defun maplist (f)
  (let ((lsts (args))(res))
    (dotimes (i (apply min (map length lsts)))
      (push (apply f (map (hayashi slice i) lsts)) res -1))
  res))

;(define (sprint) (silent (apply print (args))))
;(define (sprintln) (silent (apply println (args))))

(global 'cdr 'car 'second 'third 'fourth 'cadr 'progn 't 'equal 'char-code)
(global 'atom 'floatp 'integerp 'listp 'null 'numberp 'stringp 'symbolp 'zerop)
(global 'read-integer 'read-string)
(global 'evenp 'oddp 'consp)
(global 'remove 'remove-if 'remove-if-not)
(global 'flat1 'mappend 'mapc 'maplist)
;(global 'sprint 'sprintln)
;(constant (global '+) add))
;(constant (global '-) sub))
;(constant (global '*) mul))
;(constant (global '/) div))
(context 'MAIN:psetq)
(define-macro (psetq:psetq)
  (letn (_args (explode (args) 2)
         _temp (gensym (length _args)))
    (letex (_vars (transpose (list _temp (map second _args)))
            _pset (flat (cons 'setq (transpose (list (map first _args) _temp)))))
           (let _vars _pset))))
(context MAIN)
(context 'MAIN:multi-let)
(define-macro (multi-let:multi-let)
  (letex (_varlst (map list (args 0))
          _var (args 0)
          _val (args 1)
          _body (cons 'begin (2 (args))))
	   (let _varlst
         (map set '_var (MAIN:mklist _val)) ; corrected 2010/ 6/23
         _body)))
(context MAIN)
(context 'MAIN:map-mv)
(define-macro (map-mv:map-mv)
;(mvmap exp-functor nested-list)
   (letex (_func (args 0)
           _vals (args 1))
     (map (curry apply _func) _vals)))
(context MAIN)
(if macro
    (unless (or i+ i-)
      (macro (i+ X) (+ X 1))
      (macro (i- X) (- X 1))
      (macro (mklist Obj) (if (list? Obj) Obj (list Obj)))
      (macro (aif S A B) (let (it S) (if it A B)))
      (macro (curryEx F A) (lambda () (apply F (cons A $args))))
    )
  (begin
    (define (i+ X) (+ X 1))
    (define (i- X) (- X 1))
    (define (mklist Obj) (if (list? Obj) Obj (list Obj)))
    (define-macro (aif)
      ; (aif test-form then-form &optional else-form)
      (letex (_test-form (args 0)
              _then-form (args 1)
              _else-form (third (args)))
        (let (it _test-form)
          (if it _then-form _else-form))))
    (define-macro (curryEx)
      (letex (_func (args 0) _arg (args 1))
        (lambda () (apply _func (cons _arg $args)))))
  )
)
(global 'i+ 'i- 'aif 'mklist 'curryEx)