-
Notifications
You must be signed in to change notification settings - Fork 5
/
simple-utils.lisp
178 lines (145 loc) · 6.7 KB
/
simple-utils.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
(in-package #:simple-utils)
;;; -----------------------------------------------------------------------------------------
;;; package
;;; -----------------------------------------------------------------------------------------
(defun rename-package-nicknames (package &rest nicknames)
"for Alias short package name from too long package name."
(let ((pkg (package-name (find-package package))))
#-sbcl(rename-package pkg pkg (append nicknames (package-nicknames pkg)))
#+sbcl
(let ((lock-p (sb-ext:package-locked-p pkg)))
(when lock-p (sb-ext:unlock-package pkg))
(prog1
(rename-package pkg pkg (append nicknames (package-nicknames pkg)))
(when lock-p (sb-ext:lock-package pkg))))))
;;; -----------------------------------------------------------------------------------------
;;; file
;;; -----------------------------------------------------------------------------------------
(defun full-pathname (path)
"returning absoulte full-pathname of path"
#+ccl (namestring (ccl:full-pathname path))
#-ccl (namestring (get-fullpath path)))
#-ccl
(defun get-fullpath (dir)
(labels ((absolute-dir (dir)
(if (eql (car dir) :absolute) (if (find :home dir)
(append
(pathname-directory (user-homedir-pathname))
(cdr (member :home dir)))
dir)
(let* ((default-dir
(pathname-directory (truename ""))))
(when (find :up dir)
(setf dir (cdr dir))
(setf default-dir (butlast default-dir)))
(append default-dir (cdr dir))))))
(make-pathname :directory (absolute-dir (pathname-directory dir)) :name (pathname-name dir) :type (pathname-type dir))))
;;; -----------------------------------------------------------------------------------------
;;; external-process
;;; -----------------------------------------------------------------------------------------
(defun run-program (command &key output wait)
#+ccl (ccl:run-program "/bin/sh" (list "-c" command) :output output :wait wait)
#+sbcl (sb-ext:run-program "/bin/sh" (list "-c" command) :output output :wait wait)
#+clisp (ext:run-program "/bin/sh" :arguments (list "-c" command) :output (if (eql output t) :terminal output) :wait wait)
#+abcl (progn
wait
(ext:run-shell-command (format nil "/bin/sh -c \"~a\"" command) :output (if (eql output t) *standard-output* output)))
#+ecl (let ((*standard-output* ext:+process-standard-output+)
(*standard-input* ext:+process-standard-input+)
(*error-output* ext:+process-error-output+))
output wait
(ext:system (format nil "/bin/sh -c \"~a\"" command))))
;;; -----------------------------------------------------------------------------------------
;;; printing
;;; -----------------------------------------------------------------------------------------
(defun println (thing &rest things)
(format t "~&~{~a ~}~%" (cons thing things)))
;;; -----------------------------------------------------------------------------------------
;;; sequence
;;; -----------------------------------------------------------------------------------------
(defmacro -> (&optional arg &body body)
"(-> (+ 1 2) (* 3) (/ 3)) expand to => (/ (* (+ 1 2) 3) 3)"
(when arg
(if (not body) arg
(let* ((form (mklist (car body)))
(form (append (list (car form) arg) (cdr form))))
(reduce (lambda (x y)
(let ((y (mklist y)))
(append (list (car y) x) (cdr y)))) (append (list form) (cdr body)))))))
(defun mklist (val)
"If val is lisp, then return. but if val is atom, make list from val."
(if (listp val) val (list val)))
(defun partition (lst x)
(labels ((partition-helper (lst acc x)
(cond ((not lst) acc)
((< (length lst) x) (cons lst acc))
(t (partition-helper (subseq lst x) (cons (subseq lst 0 x) acc) x)))))
(reverse (partition-helper lst '() x))))
(defmethod cat ((sequence string) &rest sequences)
(apply #'concatenate 'string sequence sequences))
(defmethod cat ((sequence list) &rest sequences)
(apply #'append sequence sequences))
(defun dup (object &optional (n 2))
(duplicate object n))
(defmethod duplicate (self (n integer))
(if (not (listp self)) (make-list n :initial-element self)
(loop for i from 0 below n
collect (copy-list self))))
(defmethod duplicate ((self function) (n integer))
(loop for i from 0 below n collect (funcall self i)))
(defmethod duplicate ((self function) (n list))
(loop for i in n collect (funcall self i)))
(defmacro do-while ((var form) &body body)
`(do ((,var ,form ,form))
((not ,var))
,@body))
;;; -----------------------------------------------------------
;;; Math
;;;
(defun range-map (value input-min input-max output-min output-max)
"Re-maps a number from one range to another. We convert the number value where inputMin < value < inputMax into a number beetween outputMin and outputMax."
(assert (and (>= value input-min) (>= input-max value)))
(+ (* 1.0 (- output-max output-min) (/ (- value input-min) (- input-max input-min))) output-min))
;;; -----------------------------------------------------------------------------------------
;;; read macro
;;; -----------------------------------------------------------------------------------------
;;; #! read-macro - clojure style of lambda functions.
(defvar *name-db*)
(defmethod name-parse ((symbol symbol))
(let ((name-string (string-upcase symbol)))
(if (char= #\% (elt name-string 0))
(let ((number (progn (when (= 1 (length name-string))
(setq name-string (format nil "~a1" name-string)))
(parse-integer (subseq name-string 1)))))
(when (zerop number) (error "in-args number must not 0"))
(let ((sym (assoc number *name-db*)))
(if sym (cdr sym)
(let ((new-symb (cons number (gensym))))
(setf *name-db* (append *name-db* (list new-symb)))
(cdr new-symb)))))
symbol)))
(defmethod name-parse ((self t))
self)
(defun do-parse-from-form (form)
(cond ((null form) nil)
((atom form) (name-parse form))
(t (cons (do-parse-from-form (car form))
(do-parse-from-form (cdr form))))))
(defun fill-in-name-db (db)
(when db
(let ((max-number (reduce #'max db :key #'car)))
(loop for i from 1 to max-number
collect (let ((val (find i db :key #'car)))
(if val val (cons i (gensym))))))))
(set-dispatch-macro-character #\# #\!
(lambda (stream char1 char2)
(declare (ignore char1 char2))
(let ((first-char (read-char stream nil nil)))
(if (char= first-char #\space) (error "bad syntax..by #\\space")
(unread-char first-char stream)))
(let ((*name-db* nil))
(let ((body-form (do-parse-from-form (read stream nil nil)))
(args (mapcar #'cdr (fill-in-name-db *name-db*))))
`(lambda ,(concatenate 'list args '(&rest rest))
(declare (ignorable ,@args rest))
,body-form)))))