├── .gitignore ├── LICENSE ├── README.md ├── README_JPN.md ├── arrays ├── aref.LSP ├── array-dimensions.LSP ├── array-type.LSP ├── arrayp.LSP ├── make-array.LSP ├── set-aref.LSP ├── set-svref.LSP ├── simple-vector-p.LSP └── svref.LSP ├── characters ├── ControlCode-p.LSP ├── alpha-char-p.LSP ├── alphanumericp.LSP ├── char-downcase.LSP ├── char-equal.LSP ├── char-greaterp.LSP ├── char-lessp.LSP ├── char-not-equal.LSP ├── char-not-greaterp.LSP ├── char-not-lessp.LSP ├── char-upcase.LSP ├── characterp.LSP ├── digit-char-p.LSP ├── digit-char.LSP ├── lower-case-p.LSP └── upper-case-p.LSP ├── common ├── ISO-639-1.LSP ├── LISPSYS.LSP ├── default.LSP ├── float_comparison.lsp ├── float_equal.lsp ├── member-of-option-p.LSP ├── scope-p.LSP ├── scope.LSP └── tolerance.LSP ├── commonlib.png ├── conditions └── exception.LSP ├── conses ├── ALValue.LSP ├── acons.LSP ├── adjoin.LSP ├── assoc-if.LSP ├── butlast.LSP ├── cars.LSP ├── cdrs.LSP ├── chain.LSP ├── endp.LSP ├── intersection.LSP ├── last-cons.LSP ├── make-list.LSP ├── mapc.LSP ├── mapcan.LSP ├── mapcon.LSP ├── mapl.LSP ├── maplist.LSP ├── nthcdr.LSP ├── organizeGroup.lsp ├── periodic-nth.LSP ├── range.LSP ├── set-ALValue.LSP ├── set-difference.LSP ├── stack.LSP ├── sublis.LSP ├── subst-if.LSP ├── subst-tree.LSP ├── union.LSP └── zip.LSP ├── environment ├── shell-command.LSP └── time.LSP ├── evaluation ├── apply-partial.LSP ├── compose-apply.LSP ├── compose.LSP └── recurse-binOperator.LSP ├── flow ├── functionp.lsp ├── identity.LSP ├── unless.lsp ├── when.lsp └── xor.LSP ├── linear_algebra ├── 3DVector.LSP ├── determinant.LSP ├── matrix.LSP ├── matrix_Inverse-Cofactor.LSP ├── transform.LSP ├── transformation-matrix.LSP └── vector.LSP ├── numbers ├── acos.LSP ├── acosh.LSP ├── asin.LSP ├── asinh.LSP ├── atanh.LSP ├── bitlist.LSP ├── bittest.LSP ├── ceiling.LSP ├── compound.LSP ├── cosh.LSP ├── evenp.LSP ├── floor.LSP ├── integerp.LSP ├── lcm.LSP ├── log-b.LSP ├── mod.LSP ├── oddp.LSP ├── parse-integer-list.LSP ├── parse-integer.LSP ├── plusp.LSP ├── random.LSP ├── realp.LSP ├── round-off.LSP ├── signum.LSP ├── sinh.LSP ├── tan.LSP ├── tanh.LSP └── truncate.LSP ├── printer ├── _format-case-conversion.LSP ├── _format-conditional.LSP ├── _format-control-code.LSP ├── _format-directive.LSP ├── _format-float.LSP ├── _format-formatString.LSP ├── _format-in-parentheses.LSP ├── _format-integer-grouping.LSP ├── _format-integer-slist.LSP ├── _format-integer.LSP ├── _format-iteration.LSP ├── _format-justification.LSP ├── _format-prinx.LSP ├── _format-wondows-registry.LSP └── format.LSP ├── sequences ├── _sequence-type-of.LSP ├── _sequencep-list.LSP ├── _sequencep.LSP ├── affix-list.LSP ├── affix.LSP ├── concatenate.LSP ├── count-if.LSP ├── count-list-if.LSP ├── count.LSP ├── elt.LSP ├── fill-list.LSP ├── fill.LSP ├── map.LSP ├── padding-list.LSP ├── padding.LSP ├── position-if.LSP ├── position-list-if.LSP ├── position.LSP ├── prioritize-list.LSP ├── prioritize.lsp ├── reduce.LSP ├── remove-duplicates-list.LSP ├── remove-duplicates.LSP ├── remove-if.LSP ├── remove-list-if.LSP ├── remove-repetition-list.LSP ├── remove-repetition.lsp ├── remove.LSP ├── replace-all-list.LSP ├── replace-all.LSP ├── replacelis-all-list.LSP ├── replacelis-all.LSP ├── reverse-sequence.LSP ├── search-list.LSP ├── search.LSP ├── sequence-length.LSP ├── subseq-list.LSP ├── subseq.LSP ├── substitute--if.LSP ├── substitute-list-if.LSP ├── substitute.LSP ├── thin-out-list.LSP └── thin-out.LSP ├── streams ├── with-open-file.LSP └── write-string.LSP ├── strings ├── _string-trim.LSP ├── _stringp-list.LSP ├── _to-variantp-string.LSP ├── char.LSP ├── make-string.LSP ├── string-capitalize.LSP ├── string-downcase.LSP ├── string-equal.LSP ├── string-greaterp.LSP ├── string-left-trim.LSP ├── string-length.LSP ├── string-lessp.LSP ├── string-not-equal.LSP ├── string-not-greaterp.LSP ├── string-not-lessp.LSP ├── string-right-trim.LSP ├── string-trim.LSP ├── string-upcase.LSP ├── string.LSP ├── stringp.LSP ├── unword.LSP └── word.LSP ├── structures ├── assoclist-structure.LSP ├── defstruct.LSP ├── structure-assoclist.LSP └── structure-p.LSP ├── symbols └── make-handle.LSP └── types ├── AutoCAD ├── SSToList.LSP └── listToSS.LSP ├── coerce.LSP ├── multibyte ├── _Shift_JIS.LSP ├── _unicode.LSP ├── list-string.LSP ├── multi-byte-char-compare.LSP ├── multi-byte-char-func.LSP ├── multi-byte-char-p.LSP ├── multi-byte-char-types.LSP └── string-list.LSP ├── type-of.LSP └── typep.lsp /.gitignore: -------------------------------------------------------------------------------- 1 | JUNK 2 | JUNK/ 3 | commonlib.LSP 4 | commonlib.prj -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 Manual Chair Japan 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /arrays/aref.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'aref "./arrays/aref") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (setq aref vlax-safearray-get-element) 10 | -------------------------------------------------------------------------------- /arrays/array-dimensions.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'array-dimensions "./arrays/array-dimensions") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'range "./conses/range") 10 | 11 | (defun array-dimensions (array) 12 | (mapcar (function (lambda (dimension) 13 | (1+ (- (vlax-safearray-get-u-bound array dimension) 14 | (vlax-safearray-get-l-bound array dimension) 15 | ) 16 | ) 17 | ) 18 | ) 19 | (range 1 (1+ (vlax-safearray-get-dim array)) 1) 20 | ) 21 | ) -------------------------------------------------------------------------------- /arrays/array-type.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'array-type "./arrays/array-type") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'ALValue "./conses/ALValue") 10 | 11 | (setq *array:array-type->sym* 12 | (list (cons vlax-vbInteger 'INT16) 13 | (cons vlax-vbInteger 'INT) 14 | (cons vlax-vbLong 'INT) 15 | (cons vlax-vbSingle 'SINGLE) 16 | (cons vlax-vbDouble 'REAL) 17 | (cons vlax-vbString 'STR) 18 | (cons vlax-vbObject 'VLA-object) 19 | (cons vlax-vbBoolean 'BOOL) 20 | (cons vlax-vbVariant 'VARIANT) 21 | ) 22 | ) 23 | 24 | (defun array-type (array) 25 | (ALValue *array:array-type->sym* (vlax-safearray-type array)) 26 | ) 27 | -------------------------------------------------------------------------------- /arrays/arrayp.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'arrayp "./arrays/arrayp") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'typep "./types/typep") 10 | 11 | (defun arrayp (item) (typep item 'SAFEARRAY)) 12 | -------------------------------------------------------------------------------- /arrays/make-array.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'make-array "./arrays/make-array") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'member-of-option-p "./common/member-of-option-p") 10 | (include 'make-list "./conses/make-list") 11 | (include 'ALValue "./conses/ALValue") 12 | 13 | (setq *array:sym->array-type* 14 | (list (cons 'INT16 vlax-vbInteger) 15 | (cons 'INT vlax-vbLong) 16 | (cons 'SINGLE vlax-vbSingle) 17 | (cons 'REAL vlax-vbDouble) 18 | (cons 'STR vlax-vbString) 19 | (cons 'VLA-object vlax-vbObject) 20 | (cons 'BOOL vlax-vbBoolean) 21 | (cons 'VARIANT vlax-vbVariant) 22 | ) 23 | ) 24 | 25 | (defun make-array:initial-element (dimensions) 26 | (if (and dimensions (cdr dimensions)) 27 | (make-list (car dimensions) 28 | (make-array:initial-element (cdr dimensions)) 29 | ) 30 | (make-list (car dimensions) initial-element) 31 | ) 32 | ) 33 | 34 | (defun make-array (element-type dimensions initial-element / result) 35 | (if (member-of-option-p 36 | 'make-array 37 | 'element-type 38 | '(INT16 INT SINGLE REAL STR VLA-OBJECT BOOL VARIANT) 39 | ) 40 | (progn (setq result 41 | (apply 42 | 'vlax-make-safearray 43 | (cons (ALValue *array:sym->array-type* element-type) 44 | (mapcar (function (lambda (size) (cons 0 (1- size)))) 45 | dimensions 46 | ) 47 | ) 48 | ) 49 | ) 50 | (vlax-safearray-fill 51 | result 52 | (if (vl-consp initial-element) 53 | initial-element 54 | (make-array:initial-element dimensions) 55 | ) 56 | ) 57 | ) 58 | (exit) 59 | ) 60 | ) -------------------------------------------------------------------------------- /arrays/set-aref.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'set-aref "./arrays/set-aref") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (setq set-aref vlax-safearray-put-element) -------------------------------------------------------------------------------- /arrays/set-svref.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'set-svref "./arrays/set-svref") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (setq set-svref vlax-safearray-put-element) 10 | 11 | -------------------------------------------------------------------------------- /arrays/simple-vector-p.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'simple-vector-p "./arrays/simple-vector-p") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'arrayp "./arrays/arrayp") 10 | 11 | (defun simple-vector-p (item) 12 | (and (arrayp item) (= (vlax-safearray-get-dim item) 1)) 13 | ) 14 | -------------------------------------------------------------------------------- /arrays/svref.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'svref "./arrays/svref") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (setq svref vlax-safearray-get-element) 10 | -------------------------------------------------------------------------------- /characters/ControlCode-p.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'ControlCode-p "./characters/ControlCode-p") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'integerp "./numbers/integerp") 10 | 11 | (defun ControlCode-p (ascii-code) 12 | (and (integerp ascii-code) 13 | (or (<= 0 ascii-code 31 ;|NUL~UC|;) (= ascii-code 127 ;|DEL|;)) 14 | ) 15 | ) -------------------------------------------------------------------------------- /characters/alpha-char-p.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'alpha-char-p "./characters/alpha-char-p") 2 | 3 | ;;;(aplha-char-p ascii-code) 4 | ;;; 5 | ;;;ascii-code : integer 6 | ;;; 7 | ;;;retrun : T or nil 8 | 9 | ;;; +------------------------------------------------------+ 10 | ;;; Copyright (c) 2020 manual chair japan 11 | ;;; Released under the MIT license 12 | ;;; https://opensource.org/licenses/mit-license.php 13 | ;;; +------------------------------------------------------+ 14 | 15 | (include 'lower-case-p "./characters/lower-case-p") 16 | (include 'upper-case-p "./characters/upper-case-p") 17 | 18 | (defun alpha-char-p (ascii-code) 19 | (or (lower-case-p ascii-code) (upper-case-p ascii-code)) 20 | ) -------------------------------------------------------------------------------- /characters/alphanumericp.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'alphanumericp "./characters/alphanumericp") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'integerp "./numbers/integerp") 10 | (include 'alpha-char-p "./characters/alpha-char-p") 11 | (include 'scope-p "./common/scope-p") 12 | 13 | (defun alphanumericp (ascii-code) 14 | (or (alpha-char-p ascii-code) 15 | (and (integerp ascii-code) 16 | (scope-p ascii-code 48 ;|(ascii "0")|; 57 ;|(ascii "9")|;) 17 | ) 18 | ) 19 | ) -------------------------------------------------------------------------------- /characters/char-downcase.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'char-downcase "./characters/char-downcase") 2 | 3 | ;;;(char-downcase ascii-code) 4 | ;;; 5 | ;;;ascii-code : integer or structure of multibyte character 6 | ;;; 7 | ;;;retrun : If ascii-code is uppercase alphabet, retrurn the 8 | ;;; corresponding lowercase character. 9 | 10 | ;;; +------------------------------------------------------+ 11 | ;;; Copyright (c) 2020 manual chair japan 12 | ;;; Released under the MIT license 13 | ;;; https://opensource.org/licenses/mit-license.php 14 | ;;; +------------------------------------------------------+ 15 | 16 | (include 'characterp "./characters/characterp") 17 | (include 'upper-case-p "./characters/upper-case-p") 18 | 19 | (defun char-downcase (ascii-code) 20 | (if (characterp ascii-code) 21 | (if (upper-case-p ascii-code) 22 | (+ ascii-code (- (ascii "a") (ascii "A"))) 23 | ascii-code 24 | ) 25 | ) 26 | ) -------------------------------------------------------------------------------- /characters/char-equal.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'char-equal "./characters/char-equal") 2 | 3 | ;;;(char-equal char1 char2) 4 | ;;; 5 | ;;;char1 : integer or structure of multibyte character 6 | ;;; 7 | ;;;char2 : integer or structure of multibyte character 8 | ;;; 9 | ;;;return : T or nil (ignore case) 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | (include 'characterp "./characters/characterp") 18 | (include 'integerp "./numbers/integerp") 19 | (include 'char-upcase "./characters/char-upcase") 20 | 21 | (defun char-equal (char1 char2) 22 | (if (and (characterp char1) (characterp char2)) 23 | (if (and (integerp char1) (integerp char2)) 24 | (= (char-upcase char1) (char-upcase char2)) 25 | (equal char1 char2) 26 | ) 27 | (exit) 28 | ) 29 | ) -------------------------------------------------------------------------------- /characters/char-greaterp.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'char-greaterp "./characters/char-greaterp") ;_ > 2 | 3 | ;;;(char-greaterp char1 char2) 4 | ;;; 5 | ;;;char1 : integer or structure of multibyte character 6 | ;;; 7 | ;;;char2 : integer or structure of multibyte character 8 | ;;; 9 | ;;;return : T or nil (ignore case) 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | (include 'integerp "./numbers/integerp") 18 | (include 'characterp "./characters/characterp") 19 | (include 'char-upcase "./characters/char-upcase") 20 | (include 'plusp "./numbers/plusp") 21 | (include 'multi-byte-char:compare "./types/multibyte/multi-byte-char-compare") 22 | 23 | (defun char-greaterp (char1 char2) 24 | (if (and (characterp char1) (characterp char2)) 25 | (cond ((and (integerp char1) (integerp char2)) 26 | (> (char-upcase char1) (char-upcase char2)) 27 | ) 28 | ((integerp char1) nil) 29 | ((integerp char2) T) 30 | (T 31 | (plusp (multi-byte-char:compare char1 char2)) ;_ > 32 | ) 33 | ) 34 | (exit) 35 | ) 36 | ) -------------------------------------------------------------------------------- /characters/char-lessp.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'char-lessp "./characters/char-lessp") ;_ < 2 | 3 | ;;;(char-lessp char1 char2) 4 | ;;; 5 | ;;;char1 : integer or structure of multibyte character 6 | ;;; 7 | ;;;char2 : integer or structure of multibyte character 8 | ;;; 9 | ;;;return : T or nil (ignore case) 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | (include 'integerp "./numbers/integerp") 18 | (include 'characterp "./characters/characterp") 19 | (include 'char-upcase "./characters/char-upcase") 20 | (include 'multi-byte-char:compare 21 | "./types/multibyte/multi-byte-char-compare" 22 | ) 23 | 24 | (defun char-lessp (char1 char2) 25 | (if (and (characterp char1) (characterp char2)) 26 | (cond ((and (integerp char1) (integerp char2)) 27 | (< (char-upcase char1) (char-upcase char2)) 28 | ) 29 | ((integerp char1) T) 30 | ((integerp char2) nil) 31 | (T (minusp (multi-byte-char:compare char1 char2))) ;_ < 32 | ) 33 | (exit) 34 | ) 35 | ) -------------------------------------------------------------------------------- /characters/char-not-equal.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'char-not-equal "./characters/char-not-equal") 2 | 3 | ;;;(char-not-equal char1 char2) 4 | ;;; 5 | ;;;char1 : integer or structure of multibyte character 6 | ;;; 7 | ;;;char2 : integer or structure of multibyte character 8 | ;;; 9 | ;;;return : T or nil (ignore case) 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | (include 'char-equal "./characters/char-equal") 18 | 19 | (defun char-not-equal (char1 char2) 20 | (not (char-equal char1 char2)) 21 | ) -------------------------------------------------------------------------------- /characters/char-not-greaterp.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'char-not-greaterp "./characters/char-not-greaterp") ;_ <= 2 | 3 | ;;;(char-not-greaterp char1 char2) 4 | ;;; 5 | ;;;char1 : integer 6 | ;;; 7 | ;;;char2 : integer 8 | ;;; 9 | ;;;return : T or nil (ignore case) 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | (include 'characterp "./characters/characterp") 18 | (include 'char-greaterp "./characters/char-greaterp") ;_ > 19 | 20 | (defun char-not-greaterp (char1 char2) 21 | (not (char-greaterp char1 char2)) 22 | ) -------------------------------------------------------------------------------- /characters/char-not-lessp.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'char-not-lessp "./characters/char-not-lessp") ;_ >= 2 | 3 | ;;;(char-not-lessp char1 char2) 4 | ;;; 5 | ;;;char1 : integer 6 | ;;; 7 | ;;;char2 : integer 8 | ;;; 9 | ;;;return : T or nil (ignore case) 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | (include 'characterp "./characters/characterp") 18 | (include 'char-lessp "./characters/char-lessp") ;_ < 19 | 20 | (defun char-not-lessp (char1 char2) 21 | (not (char-lessp char1 char2)) 22 | ) -------------------------------------------------------------------------------- /characters/char-upcase.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'char-upcase "./characters/char-upcase") 2 | 3 | ;;;(char-upcase ascii-code) 4 | ;;; 5 | ;;;ascii-code : integer or structure of multibyte character 6 | ;;; 7 | ;;;retrun : If ascii-code is lowercase alphabet, retrurn the 8 | ;;; corresponding uppercase character. 9 | 10 | ;;; +------------------------------------------------------+ 11 | ;;; Copyright (c) 2020 manual chair japan 12 | ;;; Released under the MIT license 13 | ;;; https://opensource.org/licenses/mit-license.php 14 | ;;; +------------------------------------------------------+ 15 | 16 | (include 'characterp "./characters/characterp") 17 | (include 'lower-case-p "./characters/lower-case-p") 18 | 19 | (defun char-upcase (ascii-code) 20 | (if (characterp ascii-code) 21 | (if (lower-case-p ascii-code) 22 | (- ascii-code (- (ascii "a") (ascii "A"))) 23 | ascii-code 24 | ) 25 | ) 26 | ) -------------------------------------------------------------------------------- /characters/characterp.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'characterp "./characters/characterp") 2 | 3 | ;;;(charactorp item) 4 | ;;; 5 | ;;;item : integer or structure 6 | ;;; 7 | ;;;retrun : T or nil 8 | 9 | ;;; +------------------------------------------------------+ 10 | ;;; Copyright (c) 2020 manual chair japan 11 | ;;; Released under the MIT license 12 | ;;; https://opensource.org/licenses/mit-license.php 13 | ;;; +------------------------------------------------------+ 14 | 15 | (include '*LISPSYS* "./common/LISPSYS") 16 | (include 'integerp "./numbers/integerp") 17 | (include 'plusp "./numbers/plusp") 18 | (include 'multi-byte-char-p "./types/multibyte/multi-byte-char-p") 19 | 20 | (setq characterp (if (plusp *LISPSYS*) 21 | integerp 22 | (lambda (item) 23 | (or (and (integerp item) (<= 0 item) (<= item 255)) 24 | (multi-byte-char-p item) 25 | ) 26 | ) 27 | ) 28 | ) -------------------------------------------------------------------------------- /characters/digit-char-p.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'digit-char-p "./characters/digit-char-p") 2 | 3 | ;;;(digit-char-p ascii-code radix) 4 | ;;; 5 | ;;;ascii-code : integer 6 | ;;; 7 | ;;;radix : integer (2~36) or if nil 10 8 | ;;; 9 | ;;;retrun : integer or nil 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | ;;;_$ (digit-char-p (ascii "9") nil) 18 | ;;;9 19 | ;;;_$ (digit-char-p (ascii "a") nil) 20 | ;;;nil 21 | ;;;_$ (digit-char-p (ascii "a") 16) 22 | ;;;10 23 | ;;;_$ (digit-char-p (ascii "f") 16) 24 | ;;;15 25 | ;;;_$ (digit-char-p (ascii "g") 16) 26 | ;;;nil 27 | ;;;_$ (digit-char-p (ascii "z") 36) 28 | ;;;35 29 | 30 | (include 'default "./common/default") 31 | (include 'scope-p "./common/scope-p") 32 | (include 'integerp "./numbers/integerp") 33 | (include 'char-upcase "./characters/char-upcase") 34 | 35 | (defun digit-char-p:main (/ code value) 36 | (setq radix (default radix '10)) 37 | (if (scope-p radix 2 36) 38 | (progn 39 | (setq code (char-upcase ascii-code)) 40 | (cond ((scope-p code (ascii "0") (+ (ascii "0") (min (1- radix) 9))) 41 | (- code (ascii "0")) 42 | ) 43 | ((and (< 10 radix) 44 | (scope-p code (ascii "A") (+ (ascii "A") (- radix 11))) 45 | ) 46 | (- (+ code 10) (ascii "A")) 47 | ) 48 | ) 49 | ) 50 | (exit) 51 | ) 52 | ) 53 | 54 | (defun digit-char-p (ascii-code radix) 55 | (if (and (integerp ascii-code) 56 | (or (null radix) (integerp radix)) 57 | ) 58 | (digit-char-p:main) 59 | ) 60 | ) -------------------------------------------------------------------------------- /characters/digit-char.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'digit-char "./characters/digit-char") 2 | 3 | ;;;(digit-char i radix) 4 | ;;; 5 | ;;;i : integer 6 | ;;; 7 | ;;;radix : integer (2~36) or if nil 10 8 | ;;; 9 | ;;;retrun : integer meaning ascii-code 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | ;;;_$ (chr (digit-char 9 nil)) 18 | ;;;"9" 19 | ;;;_$ (chr (digit-char 10 nil)) 20 | ;;;; error: bad argument type: fixnump: nil 21 | ;;;_$ (chr (digit-char 10 16)) 22 | ;;;"A" 23 | ;;;_$ (chr (digit-char 15 16)) 24 | ;;;"F" 25 | ;;;_$ (chr (digit-char 35 36)) 26 | ;;;"Z" 27 | 28 | (include 'default "./common/default") 29 | (include 'scope "./common/scope") 30 | (include 'scope-p "./common/scope-p") 31 | (include 'integerp "./numbers/integerp") 32 | 33 | (defun digit-char:main () 34 | (setq radix (default radix '10)) 35 | (if (scope radix 2 36) 36 | (cond ((scope-p i 0 (min radix 9)) (+ (ascii "0") i)) 37 | ((scope-p i 10 (1- radix)) (+ (ascii "A") (- i 10))) 38 | ) 39 | (exit) 40 | ) 41 | ) 42 | 43 | 44 | (defun digit-char (i radix) 45 | (if (and (integerp i) (or (null radix) (integerp radix))) 46 | (digit-char:main) 47 | (exit) 48 | ) 49 | ) -------------------------------------------------------------------------------- /characters/lower-case-p.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'lower-case-p "./characters/lower-case-p") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'integerp "./numbers/integerp") 10 | (include 'scope-p "./common/scope-p") 11 | 12 | (defun lower-case-p (ascii-code) 13 | (and (integerp ascii-code) 14 | (scope-p ascii-code 97 ;|(ascii "a")|; 122 ;|(ascii "z")|;) 15 | ) 16 | ) -------------------------------------------------------------------------------- /characters/upper-case-p.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'upper-case-p "./characters/upper-case-p") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'integerp "./numbers/integerp") 10 | (include 'scope-p "./common/scope-p") 11 | 12 | (defun upper-case-p (ascii-code) 13 | (and (integerp ascii-code) 14 | (scope-p ascii-code 65 ;|(ascii "A")|; 90 ;|(ascii "Z")|;) 15 | ) 16 | ) -------------------------------------------------------------------------------- /common/LISPSYS.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include '*LISPSYS* "./common/LISPSYS") 2 | 3 | ;;; *LISPSYS* : integer (The value of (getvar "LISPSYS")) or -1 4 | 5 | ;;; +------------------------------------------------------+ 6 | ;;; Copyright (c) 2020 manual chair japan 7 | ;;; Released under the MIT license 8 | ;;; https://opensource.org/licenses/mit-license.php 9 | ;;; +------------------------------------------------------+ 10 | 11 | (include 'default "./common/default") 12 | 13 | (setq *LISPSYS* (default (getvar "LISPSYS") '-1)) -------------------------------------------------------------------------------- /common/default.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'default "./common/default") 2 | 3 | ;;;(default value onNull) 4 | ;;; 5 | ;;;value : atom or list 6 | ;;; 7 | ;;;onNull : expression 8 | ;;; 9 | ;;;return : If value is not nil, this return value. 10 | ;;; If value is nil, this return (eval onNull). 11 | ;;; empty string is include nil 12 | 13 | ;;; +------------------------------------------------------+ 14 | ;;; Copyright (c) 2020 manual chair japan 15 | ;;; Released under the MIT license 16 | ;;; https://opensource.org/licenses/mit-license.php 17 | ;;; +------------------------------------------------------+ 18 | 19 | (include 'typep "./types/typep") 20 | 21 | (defun default (value onNull) 22 | (if (or (and (not (typep value 'STR)) (null value)) 23 | (and (typep value 'STR) (= value "")) 24 | ) 25 | (eval onNull) 26 | value 27 | ) 28 | ) -------------------------------------------------------------------------------- /common/float_comparison.lsp: -------------------------------------------------------------------------------- 1 | ;;;(include '<:float "./common/float_comparison") 2 | ;;;(include '>:float "./common/float_comparison") 3 | ;;;(include '<=:float "./common/float_comparison") 4 | ;;;(include '>=:float "./common/float_comparison") 5 | ;;;(include 'minusp:float "./common/float_comparison") 6 | ;;;(include 'plusp:float "./common/float_comparison") 7 | 8 | ;;; +------------------------------------------------------+ 9 | ;;; Copyright (c) 2020 manual chair japan 10 | ;;; Released under the MIT license 11 | ;;; https://opensource.org/licenses/mit-license.php 12 | ;;; +------------------------------------------------------+ 13 | 14 | (include '=:float "./common/float_equal") 15 | 16 | (defun <:float (a b) (and (/=:float a b) (< a b))) 17 | 18 | (defun >:float (a b) (and (/=:float a b) (> a b))) 19 | 20 | (defun <=:float (a b) (or (=:float a b) (< a b))) 21 | 22 | (defun >=:float (a b) (or (=:float a b) (> a b))) 23 | 24 | (defun minusp:float (a) (<:float a 0.0)) 25 | 26 | (defun plusp:float (a) (<:float 0.0 a)) 27 | -------------------------------------------------------------------------------- /common/float_equal.lsp: -------------------------------------------------------------------------------- 1 | ;;;(include 'equal:float "./common/float_equal") 2 | ;;;(include '=:float "./common/float_equal") 3 | ;;;(include 'zerop:float "./common/float_equal") 4 | ;;;(include '/=:float "./common/float_equal") 5 | 6 | ;;; +------------------------------------------------------+ 7 | ;;; Copyright (c) 2020 manual chair japan 8 | ;;; Released under the MIT license 9 | ;;; https://opensource.org/licenses/mit-license.php 10 | ;;; +------------------------------------------------------+ 11 | 12 | (include '*tolerance* "./common/tolerance") 13 | 14 | (defun equal:float (a b) (equal a b *tolerance*)) 15 | 16 | (setq =:float equal:float) 17 | 18 | (defun zerop:float (a) 19 | (equal:float a 0.0) 20 | ) 21 | 22 | (defun /=:float (a b) 23 | (not (equal:float a b)) 24 | ) 25 | 26 | -------------------------------------------------------------------------------- /common/member-of-option-p.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'member-of-option-p "./common/member-of-option-p") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (defun member-of-option-p (func-symbol arg-symbol keywords) 10 | (if (member (eval arg-symbol) keywords) 11 | T 12 | (progn (princ (strcat "\n; CAUTION : " 13 | (vl-symbol-name func-symbol) 14 | "::" 15 | (vl-symbol-name arg-symbol) 16 | " - " 17 | (vl-prin1-to-string keywords) 18 | ) 19 | ) 20 | nil 21 | ) 22 | ) 23 | ) -------------------------------------------------------------------------------- /common/scope-p.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'scope-p "./common/scope-p") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include '<:float "./common/float_comparison") 10 | 11 | (defun scope-p (num scope-min scope-max) 12 | (and (or (null scope-min) (<=:float scope-min num)) 13 | (or (null scope-max) (<=:float num scope-max)) 14 | ) 15 | ) 16 | -------------------------------------------------------------------------------- /common/scope.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'scope "./common/scope") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include '<:float "./common/float_comparison") 10 | 11 | (defun scope (num scope-min scope-max) 12 | (cond ((and scope-min (<:float num scope-min)) scope-min) 13 | ((and scope-max (<:float scope-max num)) scope-max) 14 | (T num) 15 | ) 16 | ) 17 | -------------------------------------------------------------------------------- /common/tolerance.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include '*tolerance* "./common/tolerance") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (setq *tolerance* (expt 10.0 (- (* (getvar "LUPREC") 2)))) -------------------------------------------------------------------------------- /commonlib.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/manualChair/commonlib/79164a197831e89b76f86d452c55688ca0d896a6/commonlib.png -------------------------------------------------------------------------------- /conditions/exception.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'exception "./conditions/exception") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (defun exception ($_func $_args $_onException / $_result) 10 | (if $_func 11 | (if (vl-catch-all-error-p 12 | (setq $_result (vl-catch-all-apply $_func $_args)) 13 | ) 14 | ((lambda ($error $error-message) (eval $_onException)) 15 | $_result 16 | (vl-catch-all-error-message $_result) 17 | ) 18 | $_result 19 | ) 20 | (exit) 21 | ) 22 | ) 23 | -------------------------------------------------------------------------------- /conses/ALValue.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'ALValue "./conses/ALValue") 2 | 3 | ;;;(ALValue assoc-list key) 4 | ;;; 5 | ;;;assoc-list : list 6 | ;;; 7 | ;;;key : atom or list 8 | ;;; 9 | ;;;return : atom or list 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | ;;;_$ (ALValue '((PRICE . 100) (TYPE . APPLE)) 'PRICE) 18 | ;;;100 19 | 20 | (defun ALValue (assoc-list key) (cdr (assoc key assoc-list))) 21 | -------------------------------------------------------------------------------- /conses/acons.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'acons "./conses/acons") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (acons 'price 100 '((type . apple))) 10 | ;;;((PRICE . 100) (TYPE . APPLE)) 11 | 12 | (defun acons (key value assoc-list) (cons (cons key value) assoc-list)) -------------------------------------------------------------------------------- /conses/adjoin.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'adjoin "./conses/adjoin") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (adjoin 'b '(a b c) nil) 10 | ;;;(A B C) 11 | ;;;_$ (adjoin 'z '(a b c) nil) 12 | ;;;(Z A B C) 13 | 14 | (include 'default "./common/default") 15 | (include 'functionp "./flow/functionp") 16 | 17 | (defun adjoin (newitem alist test-func) 18 | (if (functionp (eval (setq test-func (default test-func ''eq)))) 19 | (if (vl-member-if 20 | (function (lambda (item) (apply test-func (list newitem item)))) 21 | alist 22 | ) 23 | alist 24 | (cons newitem alist) 25 | ) 26 | (exit) 27 | ) 28 | ) -------------------------------------------------------------------------------- /conses/assoc-if.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'assoc-if "./conses/assoc-if") 2 | 3 | ;;;(assoc-if predicate assoc-list) 4 | ;;; 5 | ;;;predicate : function symbol or list 6 | ;;; 7 | ;;;assoc-list : association list 8 | ;;; 9 | ;;;retuen : cons or list 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | ;;;_$ (assoc-if '(lambda (key) (< 2 key)) '((1 . A) (2 . B) (3 . C) (4 . D))) 18 | ;;;(3 . C) 19 | ;;;_$ (assoc-if '(lambda (key) (< 10 key)) '((1 . A) (2 . B) (3 . C) (4 . D))) 20 | ;;;nil 21 | 22 | (include 'endp "./conses/endp") 23 | 24 | (defun assoc-if:sub ($_assoc-list) 25 | (if (not (endp $_assoc-list)) 26 | (if (apply $_predicate (list (caar $_assoc-list))) 27 | (car $_assoc-list) 28 | (assoc-if:sub (cdr $_assoc-list)) 29 | ) 30 | ) 31 | ) 32 | 33 | (defun assoc-if ($_predicate $_assoc-list) (assoc-if:sub $_assoc-list)) -------------------------------------------------------------------------------- /conses/butlast.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'butlast "./conses/butlast") 2 | 3 | ;;;(butlast alist n) 4 | ;;; 5 | ;;;alist : list 6 | ;;; 7 | ;;;n : integer (default 1) 8 | ;;; 9 | ;;;return : alist without last n elements. 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | ;;;_$ (butlast '(0 1 2 3 4 5) 3) 18 | ;;;(0 1 2) 19 | ;;;_$ (butlast '(0 1 2 3 4 5) nil) 20 | ;;;(0 1 2 3 4) 21 | 22 | (include 'default "./common/default") 23 | (include 'integerp "./numbers/integerp") 24 | (include 'nthcdr "./conses/nthcdr") 25 | 26 | (defun butlast (alist n) 27 | (if (or (null n) (and (integerp n) (not (minusp n)))) 28 | (progn (setq n (default n '1)) (reverse (nthcdr n (reverse alist)))) 29 | (exit) 30 | ) 31 | ) -------------------------------------------------------------------------------- /conses/cars.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'cars "./conses/cars") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'endp "./conses/endp") 10 | 11 | (defun cars (list-alist) 12 | (if (not (endp list-alist)) 13 | (cons (car (car list-alist)) (cars (cdr list-alist))) 14 | ) 15 | ) 16 | 17 | -------------------------------------------------------------------------------- /conses/cdrs.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'cdrs "./conses/cdrs") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'endp "./conses/endp") 10 | 11 | (defun cdrs (list-alist) 12 | (if (not (endp list-alist)) 13 | (cons (cdr (car list-alist)) (cdrs (cdr list-alist))) 14 | ) 15 | ) 16 | 17 | -------------------------------------------------------------------------------- /conses/chain.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'chain "./conses/chain") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (chain '(A B C D) nil) 10 | ;;;((A B) (B C) (C D)) 11 | ;;;_$ (chain '(A B C D) T) 12 | ;;;((A B) (B C) (C D) (D A)) 13 | 14 | (defun chain:sub (alist) 15 | (if (and (not (null alist)) (cdr alist)) 16 | (cons (list (car alist) (cadr alist)) (chain:sub (cdr alist))) 17 | (if closed 18 | (list (list (car alist) start)) 19 | ) 20 | ) 21 | ) 22 | 23 | (defun chain (alist closed / start) 24 | (setq start (car alist)) 25 | (chain:sub alist) 26 | ) -------------------------------------------------------------------------------- /conses/endp.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'endp "./conses/endp") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (defun endp (alist) 10 | (if (listp alist) 11 | (null alist) 12 | (exit) 13 | ) 14 | ) -------------------------------------------------------------------------------- /conses/intersection.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'intersection "./conses/intersection") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (intersection '(a b c) '(b b c) nil) 10 | ;;;(B C) 11 | 12 | (defun intersection (alist1 alist2 test-func) 13 | (if (functionp (eval (setq test-func (default test-func ''eq)))) 14 | (vl-remove-if-not 15 | (function 16 | (lambda (item) 17 | (vl-member-if 18 | (function 19 | (lambda (sub-item) (apply test-func (list item sub-item))) 20 | ) 21 | alist2 22 | ) 23 | ) 24 | ) 25 | alist1 26 | ) 27 | (exit) 28 | ) 29 | ) -------------------------------------------------------------------------------- /conses/last-cons.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'last-cons "./conses/last-cons") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (last-cons '(a b c d) 1) 10 | ;;;(D) 11 | ;;;_$ (last-cons '(a b c d) 2) 12 | ;;;(C D) 13 | ;;;_$ (last-cons '(a b c d) 0) 14 | ;;;nil 15 | ;;;_$ (last-cons '(a b c d . e) 1) 16 | ;;;(D . E) 17 | ;;;_$ (last-cons '(a b c d . e) 2) 18 | ;;;(C D . E) 19 | ;;;_$ (last-cons '(a b c d . e) 0) 20 | ;;;E 21 | 22 | (include 'default "./common/default") 23 | (include 'integerp "./numbers/integerp") 24 | 25 | (defun last-cons:sub (alist / temp) 26 | (if (vl-consp alist) 27 | (progn (setq temp (last-cons:sub (cdr alist))) 28 | (if (< count n) 29 | (progn (setq count (1+ count)) (cons (car alist) temp)) 30 | temp 31 | ) 32 | ) 33 | (progn (setq count 0) alist) 34 | ) 35 | ) 36 | 37 | (defun last-cons (alist n / count) 38 | (setq n (default n '1)) 39 | (if (and (integerp n) (not (minusp n))) 40 | (last-cons:sub alist) 41 | (exit) 42 | ) 43 | ) -------------------------------------------------------------------------------- /conses/make-list.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'make-list "./conses/make-list") 2 | 3 | ;;;(make-size size initial-element) 4 | ;;; 5 | ;;;size : integer 6 | ;;; 7 | ;;;initial-element : atom or list 8 | ;;; 9 | ;;;retuen : list 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | ;;;_$ (make-list 0 0.0) 18 | ;;;nil 19 | ;;;_$ (make-list 1 0.0) 20 | ;;;(0.0) 21 | ;;;_$ (make-list 5 0.0) 22 | ;;;(0.0 0.0 0.0 0.0 0.0) 23 | 24 | (include 'integerp "./numbers/integerp") 25 | (include 'plusp "./numbers/plusp") 26 | 27 | (defun make-list (size initial-element) 28 | (if (and (integerp size) (not (minusp size))) 29 | (if (< 0 size) 30 | (cons initial-element (make-list (1- size) initial-element)) 31 | ) 32 | (exit) 33 | ) 34 | ) 35 | -------------------------------------------------------------------------------- /conses/mapc.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'mapc "./conses/mapc") 2 | 3 | ;;;(mapc $_func $_list-alist) 4 | ;;; 5 | ;;;$_func : function symbol or list 6 | ;;; 7 | ;;;$_list-alist : list ex. '((A B C) (1 2 3)) 8 | ;;; 9 | ;;;return : list ex. '(A B C) 10 | ;;; this call ($_func A 1) ($_func B 2) ($_func C 3) 11 | 12 | ;;; +------------------------------------------------------+ 13 | ;;; Copyright (c) 2020 manual chair japan 14 | ;;; Released under the MIT license 15 | ;;; https://opensource.org/licenses/mit-license.php 16 | ;;; +------------------------------------------------------+ 17 | 18 | ;;;_$ (mapc 'print '((1 2 3))) 19 | ;;; 20 | ;;;1 21 | ;;;2 22 | ;;;3 (1 2 3) 23 | 24 | (include 'endp "./conses/endp") 25 | (include 'cars "./conses/cars") 26 | (include 'cdrs "./conses/cdrs") 27 | 28 | (defun mapc:sub ($_list-alist / $_args) 29 | (if (vl-every (function (lambda (alist) (not (endp alist)))) $_list-alist) 30 | (progn (apply $_func (setq $_args (cars $_list-alist))) 31 | (cons (car $_args) (mapc:sub (cdrs $_list-alist))) 32 | ) 33 | ) 34 | ) 35 | 36 | (defun mapc ($_func $_list-alist) (mapc:sub $_list-alist)) -------------------------------------------------------------------------------- /conses/mapcan.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'mapcan "./conses/mapcan") 2 | 3 | ;;;(mapcan func list-alist) 4 | ;;; 5 | ;;;func : list of function symbol or list 6 | ;;; 7 | ;;;list-alist : list of list. ex. '((A B C) (1 2 3)) 8 | ;;; 9 | ;;;retrun : list 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | ;;;_$ (mapcan 'list '((A B C) (1 2 3))) 18 | ;;;(A 1 B 2 C 3) 19 | 20 | (defun mapcan (func list-alist) 21 | (apply 'append (apply 'mapcar (cons func list-alist))) 22 | ) -------------------------------------------------------------------------------- /conses/mapcon.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'mapcon "./conses/mapcon") 2 | 3 | ;;;(mapcon $_func $_list-alist) 4 | ;;; 5 | ;;;$_func : list of function symbol or list 6 | ;;; 7 | ;;;$_list-alist : list of list. ex. '((A B C) (1 2 3)) 8 | ;;; 9 | ;;;retrun : list 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | ;;;_$ (mapcon 'identity '((0 1 2 3 4 5 6))) 18 | ;;;(0 1 2 3 4 5 6 1 2 3 4 5 6 2 3 4 5 6 3 4 5 6 4 5 6 5 6 6) 19 | ;;;_$ (mapcon '(lambda (item1 item2) (append item1 item2)) '((0 1 2) (A B C))) 20 | ;;;(0 1 2 A B C 1 2 B C 2 C) 21 | 22 | (include 'maplist "./conses/maplist") 23 | 24 | (defun mapcon ($_func $_list-alist) 25 | (apply 'append (maplist $_func $_list-alist)) 26 | ) -------------------------------------------------------------------------------- /conses/mapl.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'mapl "./conses/mapl") 2 | 3 | ;;;(mapl $_func $_list-alist) 4 | ;;; 5 | ;;;$_func : list of function symbol or list 6 | ;;; 7 | ;;;$_list-alist : list of list. ex. '((A B C) (1 2 3)) 8 | ;;; 9 | ;;;retrun : list 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | ;;;_$ (mapl 'identity '((0 1 2 3 4 5 6))) 18 | ;;;((0 1 2 3 4 5 6) (1 2 3 4 5 6) (2 3 4 5 6) (3 4 5 6) (4 5 6) (5 6) (6)) 19 | ;;;_$ (mapl '(lambda (item1 item2) (append item1 item2)) '((0 1 2) (A B C))) 20 | ;;;((0 1 2) (1 2) (2)) 21 | 22 | (include 'endp "./conses/endp") 23 | (include 'cdrs "./conses/cdrs") 24 | 25 | (defun mapl:sub ($_list-alist) 26 | (if 27 | (vl-every (function (lambda (alist) (not (endp alist)))) $_list-alist) 28 | (progn (apply $_func $_list-alist) 29 | (cons (caar $_list-alist) (mapl:sub (cdrs $_list-alist))) 30 | ) 31 | ) 32 | ) 33 | 34 | (defun mapl ($_func $_list-alist) (mapl:sub $_list-alist)) 35 | -------------------------------------------------------------------------------- /conses/maplist.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'maplist "./conses/maplist") 2 | 3 | ;;;(maplist $_func $_list-alist) 4 | ;;; 5 | ;;;$_func : list of function symbol or list 6 | ;;; 7 | ;;;$_list-alist : list of list. ex. '((A B C) (1 2 3)) 8 | ;;; 9 | ;;;retrun : list 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | ;;;_$ (maplist 'identity '((0 1 2 3 4 5 6))) 18 | ;;;((0 1 2 3 4 5 6) (1 2 3 4 5 6) (2 3 4 5 6) (3 4 5 6) (4 5 6) (5 6) (6)) 19 | ;;;_$ (maplist '(lambda (item1 item2) (append item1 item2)) '((0 1 2) (A B C))) 20 | ;;;((0 1 2 A B C) (1 2 B C) (2 C)) 21 | 22 | (include 'endp "./conses/endp") 23 | (include 'cdrs "./conses/cdrs") 24 | 25 | (defun maplist:sub ($_list-alist) 26 | (if (vl-every (function (lambda (alist) (not (endp alist)))) $_list-alist) 27 | (cons (apply $_func $_list-alist) (maplist:sub (cdrs $_list-alist))) 28 | ) 29 | ) 30 | 31 | (defun maplist ($_func $_list-alist) (maplist:sub $_list-alist)) 32 | -------------------------------------------------------------------------------- /conses/nthcdr.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'nthcdr "./conses/nthcdr") 2 | 3 | ;;;(nthcdr n alist) 4 | ;;; 5 | ;;;n : integer (default 1) 6 | ;;; 7 | ;;;alist : list 8 | ;;; 9 | ;;;return : equivalent to calling cdr n times. 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | ;;;_$ (nthcdr 2 '(0 1 2 3 4 5)) 18 | ;;;(2 3 4 5) 19 | 20 | (include 'integerp "./numbers/integerp") 21 | (include 'endp "./conses/endp") 22 | 23 | (defun nthcdr:sub (n alist) 24 | (if (and (< 0 n) (not (endp alist))) 25 | (nthcdr:sub (1- n) (cdr alist)) 26 | alist 27 | ) 28 | ) 29 | 30 | (defun nthcdr (n alist) 31 | (if (and (integerp n) (not (minusp n)) (listp alist)) 32 | (nthcdr:sub n alist) 33 | (exit) 34 | ) 35 | ) -------------------------------------------------------------------------------- /conses/organizeGroup.lsp: -------------------------------------------------------------------------------- 1 | ;;;(include 'organizeGroup "./conses/organizeGroup") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (organizeGroup '(0 1 2 3 4 5 6 7 8 9) 3 nil) 10 | ;;;((0 1 2) (3 4 5) (6 7 8)) 11 | ;;;_$ (organizeGroup '(0 1 2 3 4 5 6 7 8 9) 3 T) 12 | ;;;((0 1 2) (3 4 5) (6 7 8) (9)) 13 | 14 | (defun organizeGroup:main (alist / stock) 15 | (if (and (not (null alist)) (<= capacity (length alist))) 16 | (progn (repeat capacity 17 | (setq stock (cons (car alist) stock) 18 | alist (cdr alist) 19 | ) 20 | ) 21 | (cons (reverse stock) (organizeGroup:main alist)) 22 | ) 23 | (if remnant (list alist)) 24 | ) 25 | ) 26 | 27 | (defun organizeGroup (alist capacity remnant) (organizeGroup:main alist)) 28 | -------------------------------------------------------------------------------- /conses/periodic-nth.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'periodic-nth "./conses/periodic-nth") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (periodic-nth 5 '(0 1 2 3 4 5)) 10 | ;;;5 11 | ;;;_$ (periodic-nth 6 '(0 1 2 3 4 5)) 12 | ;;;0 13 | ;;;_$ (periodic-nth -1 '(0 1 2 3 4 5)) 14 | ;;;5 15 | 16 | (include 'mod "./numbers/mod") 17 | 18 | (defun periodic-nth (index alist) (nth (mod index (length alist)) alist)) -------------------------------------------------------------------------------- /conses/range.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'range "./conses/range") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (range 10 3 -2) 10 | ;;;(10 8 6 4) 11 | ;;;_$ (range nil 3 nil) 12 | ;;;(0 1 2) 13 | ;;;_$ (range nil -3 nil) 14 | ;;;nil 15 | ;;;_$ (range 3 10 nil) 16 | ;;;(3 4 5 6 7 8 9) 17 | ;;;_$ (range 10 3 nil) 18 | ;;;nil 19 | ;;;_$ (range -3 3 nil) 20 | ;;;(-3 -2 -1 0 1 2) 21 | ;;;_$ (range 3 -3 nil) 22 | ;;;nil 23 | ;;;_$ (range 3 10 2) 24 | ;;;(3 5 7 9) 25 | ;;;_$ (range 10 3 2) 26 | ;;;nil 27 | ;;;_$ (range 10 3 -2) 28 | ;;;(10 8 6 4) 29 | ;;;_$ (range 3 10 -2) 30 | ;;;nil 31 | 32 | (include 'default "./common/default") 33 | 34 | (defun renge:sub (index) 35 | (if (apply judgefunc (list index end)) 36 | (cons index (renge:sub (+ index step))) 37 | ) 38 | ) 39 | 40 | (defun range (start end step / judgefunc) 41 | (if (and (or (null start) (numberp start)) 42 | (numberp end) 43 | (or (null step) (and (numberp step) (not (zerop step)))) 44 | ) 45 | (progn (setq start (default start '0) 46 | step (default step '1) 47 | judgefunc (if (< end start) 48 | (if (minusp step) 49 | '> 50 | ) 51 | (if (not (minusp step)) 52 | '< 53 | ) 54 | ) 55 | ) 56 | (if judgefunc 57 | (renge:sub start) 58 | ) 59 | ) 60 | (exit) 61 | ) 62 | ) 63 | -------------------------------------------------------------------------------- /conses/set-ALValue.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'set-ALValue "./conses/set-ALValue") 2 | 3 | ;;;(set-ALValue assoc-list key value) 4 | ;;; 5 | ;;;assoc-list : list 6 | ;;; 7 | ;;;key : atom or list 8 | ;;; 9 | ;;;value : atom or list 10 | ;;; 11 | ;;;return : list 12 | 13 | ;;; +------------------------------------------------------+ 14 | ;;; Copyright (c) 2020 manual chair japan 15 | ;;; Released under the MIT license 16 | ;;; https://opensource.org/licenses/mit-license.php 17 | ;;; +------------------------------------------------------+ 18 | 19 | ;;;_$ (set-ALValue '((PRICE . 100) (TYPE . APPLE)) 'PRICE 108) 20 | ;;;((PRICE . 108) (TYPE . APPLE)) 21 | 22 | (include 'acons "./conses/acons") 23 | 24 | (defun set-ALValue (assoc-list key value / cell) 25 | (if (setq cell (assoc key assoc-list)) 26 | (subst (cons key value) cell assoc-list) 27 | (acons key value assoc-list) 28 | ) 29 | ) 30 | -------------------------------------------------------------------------------- /conses/set-difference.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'set-difference "./conses/set-difference") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (set-difference '(a b c d e) '(b e) nil) 10 | ;;;(A C D) 11 | 12 | (include 'functionp "./flow/functionp") 13 | 14 | (defun set-difference (minuend subtrahend test-func) 15 | (if (functionp (eval (setq test-func (default test-func ''eq)))) 16 | (vl-remove-if 17 | (function 18 | (lambda (item) 19 | (vl-member-if 20 | (function 21 | (lambda (sub-item) (apply test-func (list item sub-item))) 22 | ) 23 | subtrahend 24 | ) 25 | ) 26 | ) 27 | minuend 28 | ) 29 | (exit) 30 | ) 31 | ) -------------------------------------------------------------------------------- /conses/stack.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'create-stack "./conses/stack") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (setq s (create-stack '(A B))) 10 | ;;;*ST:HND-6* 11 | ;;;_$ (push 'C s) 12 | ;;;*ST:HND-6* 13 | ;;;_$ (push 'D s) 14 | ;;;*ST:HND-6* 15 | ;;;_$ (pop s) 16 | ;;;D 17 | ;;;_$ (pop s) 18 | ;;;C 19 | ;;;_$ (pop s) 20 | ;;;A 21 | ;;;_$ (pop s) 22 | ;;;B 23 | ;;;_$ (pop s) 24 | ;;;nil 25 | ;;;_$ (pop s) 26 | ;;;nil 27 | ;;;_$ (release-handle s) 28 | ;;;nil 29 | 30 | (include 'defstruct "./structures/defstruct") 31 | (include 'make-handle "./symbols/make-handle") 32 | 33 | (defstruct 'stack '((data))) 34 | 35 | (setq create-stack 36 | (eval 37 | (list 38 | 'lambda 39 | '(data) 40 | (list 'make-handle ''ST (list (eval make-stack) 'data)) 41 | ) 42 | ) 43 | ) 44 | 45 | (defun pop (handle / result) 46 | (setq result (car (stack-data (vl-symbol-value handle)))) 47 | (set handle (make-stack (cdr (stack-data (vl-symbol-value handle))))) 48 | result 49 | ) 50 | 51 | (defun push (item handle) 52 | (set handle 53 | (make-stack (cons item (stack-data (vl-symbol-value handle)))) 54 | ) 55 | handle 56 | ) -------------------------------------------------------------------------------- /conses/sublis.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'sublis "./conses/sublis") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (sublis '((old . new) (1 . #)) '(old 1 knowledge in (old 1 milk can)) nil) 10 | ;;;(NEW # KNOWLEDGE IN (NEW # MILK CAN)) 11 | 12 | (include 'subst-tree "./conses/subst-tree") 13 | 14 | (defun sublis (assoc-list tree-list test-func / cell) 15 | (foreach cell assoc-list 16 | (setq tree-list (subst-tree (cdr cell) (car cell) tree-list test-func)) 17 | ) 18 | tree-list 19 | ) -------------------------------------------------------------------------------- /conses/subst-if.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'subst-if "./conses/subst-if") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (subst-if nil '(lambda (x) (and (numberp x) (zerop (rem x 2)))) '(0 1 2 3 4 5 6)) 10 | ;;;(nil 1 nil 3 nil 5 nil) 11 | ;;;_$ (subst-if nil '(lambda (x) (and (numberp x) (zerop (rem x 2)))) '(0 1 (2 3) 4 (5 6))) 12 | ;;;(nil 1 (nil 3) nil (5 nil)) 13 | 14 | (include 'endp "./conses/endp") 15 | 16 | (defun subst-if:sub ($_item) 17 | (cond ((atom $_item) 18 | (if (apply $_predicate (list $_item)) 19 | $_new-item 20 | $_item 21 | ) 22 | ) 23 | ((apply $_predicate (list $_item)) 24 | $_new-item 25 | ) 26 | (T (cons (subst-if:sub (car $_item)) (subst-if:sub (cdr $_item)))) 27 | ) 28 | ) 29 | 30 | (defun subst-if ($_new-item $_predicate $_tree-list) 31 | (subst-if:sub $_tree-list) 32 | ) 33 | -------------------------------------------------------------------------------- /conses/subst-tree.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'subst-tree "./conses/subst-tree") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (subst-tree nil 1 '(0 1 1 0 1 1 2) nil) 10 | ;;;(0 nil nil 0 nil nil 2) 11 | ;;;_$ (subst-tree nil 1 '(0 1 (1 0) 1 (1 2)) nil) 12 | ;;;(0 nil (nil 0) nil (nil 2)) 13 | ;;;_$ (subst-tree '(5 . A) '(5 . B) '((1 . #) (5 . B) (10 . #)) 'equal) 14 | ;;;((1 . #) (5 . A) (10 . #)) 15 | ;;;_$ (subst-tree nil 1 '(0 1 2 A 6) '(lambda (olditem x) (and (numberp x) (< olditem x)))) 16 | ;;;(0 1 nil A nil) 17 | 18 | (include 'functionp "./flow/functionp") 19 | (include 'subst-if "./conses/subst-if") 20 | 21 | (defun subst-tree (newitem olditem tree-list test-func) 22 | (if (functionp (eval (setq test-func (default test-func ''eq)))) 23 | (subst-if 24 | newitem 25 | (function 26 | (lambda (test-item) (apply test-func (list olditem test-item))) 27 | ) 28 | tree-list 29 | ) 30 | (exit) 31 | ) 32 | ) -------------------------------------------------------------------------------- /conses/union.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'union "./conses/union") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (union '(a b c) '(c b s) nil) 10 | ;;;(A C B S) 11 | 12 | (include 'set-difference "./conses/set-difference") 13 | 14 | (defun union (alist1 alist2 test-func) 15 | (append (set-difference alist1 alist2 test-func) alist2) 16 | ) -------------------------------------------------------------------------------- /conses/zip.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'zip "./conses/zip") 2 | 3 | ;;;(zip list-alist) 4 | ;;; 5 | ;;;list-alist : list ex. '((A B C) (1 2 3)) 6 | ;;; 7 | ;;;return : list 8 | 9 | ;;; +------------------------------------------------------+ 10 | ;;; Copyright (c) 2020 manual chair japan 11 | ;;; Released under the MIT license 12 | ;;; https://opensource.org/licenses/mit-license.php 13 | ;;; +------------------------------------------------------+ 14 | 15 | ;;;_$ (zip '((1 2 3) (A B C))) 16 | ;;;((1 A) (2 B) (3 C)) 17 | ;;;_$ (zip '((1 2 3) (A B C) ("a" "b" "c"))) 18 | ;;;((1 A "a") (2 B "b") (3 C "c")) 19 | 20 | (defun zip (list-alist) (apply 'mapcar (cons 'list list-alist))) 21 | -------------------------------------------------------------------------------- /environment/shell-command.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'shell-command "./environment/shell-command") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'member-of-option-p "./common/member-of-option-p") 10 | (vl-arx-import 'startapp) 11 | 12 | (defun shell-command (command-line mode) 13 | (if (member-of-option-p 'shell-command 'mode '(KEEP CLOSE)) 14 | (startapp "cmd" 15 | (strcat (cond ((= mode 'KEEP) "/K") 16 | (T "/C") 17 | ) 18 | " " 19 | command-line 20 | ) 21 | ) 22 | (exit) 23 | ) 24 | ) 25 | -------------------------------------------------------------------------------- /environment/time.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'time "./environment/time") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'format "./printer/format") 10 | 11 | (setq *time-output* 12 | (lambda (seconds) 13 | (format T 14 | "\nComputation time : ~D seconds." 15 | (list seconds) 16 | ) 17 | ) 18 | ) 19 | 20 | (defun time (func args / date result) 21 | (setq date (getvar "DATE") 22 | result (apply func args) 23 | ) 24 | (apply '*time-output* (list (* 86400.0 (- (getvar "DATE") date)))) 25 | result 26 | ) 27 | -------------------------------------------------------------------------------- /evaluation/apply-partial.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'apply-partial "./evaluation/apply-partial") 2 | 3 | ;;;(apply-partial func-symbol partialArgs slots) 4 | ;;; 5 | ;;;func-symbol : function symbol or list 6 | ;;; 7 | ;;;partialArgs : list of applied argments 8 | ;;; 9 | ;;;slots : list of index no-applied argments. 10 | ;;; Start is 1. 11 | ;;; 12 | ;;;return : function 13 | 14 | ;;; +------------------------------------------------------+ 15 | ;;; Copyright (c) 2020 manual chair japan 16 | ;;; Released under the MIT license 17 | ;;; https://opensource.org/licenses/mit-license.php 18 | ;;; +------------------------------------------------------+ 19 | 20 | (include 'default "./common/default") 21 | 22 | (defun apply-partial:sub (/ arrangeArgs) 23 | (defun arrangeArgs (counter alist slist) 24 | (if slist 25 | (if (= counter (car slist)) 26 | (append (list (read (strcat "$_" (itoa counter)))) 27 | (arrangeArgs (1+ counter) alist (cdr slist)) 28 | ) 29 | (if alist 30 | (append (list (car alist)) 31 | (arrangeArgs (1+ counter) (cdr alist) slist) 32 | ) 33 | (exit) 34 | ) 35 | ) 36 | alist 37 | ) 38 | ) 39 | (eval 40 | (list 41 | 'lambda 42 | (mapcar (function (lambda (slot) (read (strcat "$_" (itoa slot))))) 43 | slots 44 | ) 45 | (append 46 | (list (eval func-symbol)) 47 | (arrangeArgs 48 | 1 49 | (mapcar (function (lambda (arg) (list 'quote arg))) partialArgs) 50 | slots 51 | ) 52 | ) 53 | ) 54 | ) 55 | ) 56 | 57 | (defun apply-partial (func-symbol partialArgs slots) 58 | (if (default (eval func-symbol) 59 | '(progn 60 | (print "apply-partial - no function definition : ") 61 | (princ func-symbol) 62 | (exit) 63 | ) 64 | ) 65 | (apply-partial:sub) 66 | ) 67 | ) -------------------------------------------------------------------------------- /evaluation/compose-apply.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'compose-apply "./evaluation/compose-apply") 2 | 3 | ;;;(compose-apply apply-Func1 apply-Func2) 4 | ;;; 5 | ;;;apply-Func1 : function symbol or list 6 | ;;; function apply func & list of arguments. 7 | ;;; 8 | ;;;apply-Func2 : symbol of function or list 9 | ;;; function apply func & list of arguments. 10 | ;;; 11 | ;;;return : function 12 | 13 | ;;; +------------------------------------------------------+ 14 | ;;; Copyright (c) 2020 manual chair japan 15 | ;;; Released under the MIT license 16 | ;;; https://opensource.org/licenses/mit-license.php 17 | ;;; +------------------------------------------------------+ 18 | 19 | (include 'default "./common/default") 20 | 21 | (defun compose-apply (apply-Func1 apply-Func2 / func1 func2) 22 | (setq func1 (eval apply-Func1) 23 | func2 (eval apply-Func2) 24 | ) 25 | (if (and func1 func2) 26 | (eval (list 'lambda 27 | '($_func $_args) 28 | (list (eval apply-Func1) 29 | (list 'quote (list 'quote (eval apply-Func2))) 30 | '(list $_func $_args) 31 | ) 32 | ) 33 | ) 34 | (if func1 35 | func1 36 | func2 37 | ) 38 | ) 39 | ) 40 | -------------------------------------------------------------------------------- /evaluation/compose.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'compose "./evaluation/compose") 2 | 3 | ;;;(compose arg-func1 arg-func2) 4 | ;;; 5 | ;;;arg-func1 : function symbol or list 6 | ;;; function apply single argment. 7 | ;;; 8 | ;;;arg-func2 : function symbol or list 9 | ;;; function apply single argment. 10 | ;;; 11 | ;;;return : function 12 | 13 | ;;; +------------------------------------------------------+ 14 | ;;; Copyright (c) 2020 manual chair japan 15 | ;;; Released under the MIT license 16 | ;;; https://opensource.org/licenses/mit-license.php 17 | ;;; +------------------------------------------------------+ 18 | 19 | (defun compose (arg-func1 arg-func2 / func1 func2) 20 | (setq func1 (eval arg-func1) 21 | func2 (eval arg-func2) 22 | ) 23 | (if (and func1 func2) 24 | (eval (list 'lambda '($_item) (list func2 (list func1 '$_item)))) 25 | (if func1 26 | func1 27 | func2 28 | ) 29 | ) 30 | ) 31 | -------------------------------------------------------------------------------- /evaluation/recurse-binOperator.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'recurse-binaryOperator "./evaluation/recurse-binOperator") 2 | 3 | ;;;(recurse-binaryOperator func-symbol) 4 | ;;; 5 | ;;;func-symbol : function symbol or list 6 | ;;; function apply two argment. 7 | ;;; 8 | ;;;return : function 9 | 10 | ;;; +------------------------------------------------------+ 11 | ;;; Copyright (c) 2020 manual chair japan 12 | ;;; Released under the MIT license 13 | ;;; https://opensource.org/licenses/mit-license.php 14 | ;;; +------------------------------------------------------+ 15 | 16 | (include 'default "./common/default") 17 | 18 | (defun recurse-binaryOperator (func-symbol) 19 | (if 20 | (default (eval func-symbol) 21 | '(progn 22 | (print "recurse-binaryOperator - no function definition : ") 23 | (princ func-symbol) 24 | (exit) 25 | ) 26 | ) 27 | (eval 28 | (list 29 | 'lambda 30 | '(alist) 31 | (list '(lambda ($_recursiveFunction /) ($_recursiveFunction alist)) 32 | (list 'lambda 33 | '(listArg) 34 | (list 'if 35 | '(< 1 (length listArg)) 36 | (list (eval func-symbol) 37 | '(car listArg) 38 | '($_recursiveFunction (cdr listArg)) 39 | ) 40 | '(car listArg) 41 | ) 42 | ) 43 | ) 44 | ) 45 | ) 46 | ) 47 | ) 48 | -------------------------------------------------------------------------------- /flow/functionp.lsp: -------------------------------------------------------------------------------- 1 | ;;;(include 'functionp "./flow/functionp") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'type-of "./types/type-of") 10 | 11 | (defun functionp (item / itype) 12 | (setq itype (type-of item)) 13 | (or (= itype 'SUBR) (= itype 'USUBR) (= itype 'EXRXSUBR)) 14 | ) -------------------------------------------------------------------------------- /flow/identity.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'identity "./flow/identity") 2 | 3 | ;;;(identity object) 4 | ;;; 5 | ;;;object : atom or list 6 | ;;; 7 | ;;;return : object 8 | 9 | ;;; +------------------------------------------------------+ 10 | ;;; Copyright (c) 2020 manual chair japan 11 | ;;; Released under the MIT license 12 | ;;; https://opensource.org/licenses/mit-license.php 13 | ;;; +------------------------------------------------------+ 14 | 15 | (defun identity (object) 16 | object 17 | ) -------------------------------------------------------------------------------- /flow/unless.lsp: -------------------------------------------------------------------------------- 1 | ;;;(include 'unless "./flow/unless") 2 | 3 | ;;;(unless value expression) 4 | ;;; 5 | ;;;value : atom or list 6 | ;;; 7 | ;;;expression : expression 8 | ;;; 9 | ;;;return : If value is nil, this return (eval expression). 10 | ;;; In other cases, This return nil 11 | 12 | ;;; +------------------------------------------------------+ 13 | ;;; Copyright (c) 2020 manual chair japan 14 | ;;; Released under the MIT license 15 | ;;; https://opensource.org/licenses/mit-license.php 16 | ;;; +------------------------------------------------------+ 17 | 18 | (defun unless (value expression) 19 | (if (null value) 20 | (eval expression) 21 | ) 22 | ) -------------------------------------------------------------------------------- /flow/when.lsp: -------------------------------------------------------------------------------- 1 | ;;;(include 'when "./flow/when") 2 | 3 | ;;;(when value expression) 4 | ;;; 5 | ;;;value : atom or list 6 | ;;; 7 | ;;;expression : expression 8 | ;;; 9 | ;;;return : If value is not nil, this return (eval expression). 10 | ;;; In other cases, This return nil 11 | 12 | ;;; +------------------------------------------------------+ 13 | ;;; Copyright (c) 2020 manual chair japan 14 | ;;; Released under the MIT license 15 | ;;; https://opensource.org/licenses/mit-license.php 16 | ;;; +------------------------------------------------------+ 17 | 18 | (defun when (value expression) 19 | (if value 20 | (eval expression) 21 | ) 22 | ) -------------------------------------------------------------------------------- /flow/xor.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'xor "./flow/xor") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (defun xor (expr1 expr2) 10 | (or (and (not expr1) expr2) 11 | (and expr1 (not expr2)) 12 | ) 13 | ) -------------------------------------------------------------------------------- /linear_algebra/matrix_Inverse-Cofactor.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'matrix:Inverse "./linear_algebra/matrix_Inverse-Cofactor") 2 | 3 | ;;;================================================== 4 | ;;; 5 | ;;;This module include below functions 6 | ;;; 7 | ;;;================================================== 8 | ;;;(matrix:Inverse-Cofactor amatrix) 9 | ;;;(matrix:Inverse amatrix) 10 | ;;;-------------------------------------------------- 11 | ;;;_$ (matrix:Inverse-Cofactor '((1 2) (1 3))) 12 | ;;;((3.0 -2.0) (-1.0 1.0)) 13 | ;;;_$ (matrix:Inverse-Cofactor '((2 0 1) (1 2 2) (4 0 1))) 14 | ;;;((-0.5 0.0 0.5) (-1.75 0.5 0.75) (2.0 0.0 -1.0)) 15 | ;;;================================================== 16 | 17 | ;;; +------------------------------------------------------+ 18 | ;;; Copyright (c) 2020 manual chair japan 19 | ;;; Released under the MIT license 20 | ;;; https://opensource.org/licenses/mit-license.php 21 | ;;; +------------------------------------------------------+ 22 | 23 | (include 'range "./conses/range") 24 | (include 'vector "./linear_algebra/vector") 25 | (include 'matrix "./linear_algebra/matrix") 26 | (include 'determinant "./linear_algebra/determinant") 27 | 28 | ;; Cofactor matrix 29 | 30 | (defun matrix:CofactorMatrix (amatrix / ilist) 31 | (setq ilist (range 0 (length amatrix) 1)) 32 | (matrix:Transpose 33 | (mapcar 34 | (function 35 | (lambda (i) 36 | (mapcar '(apply-partial 'Cofactor (list amatrix i) '(3)) ilist) 37 | ) 38 | ) 39 | ilist 40 | ) 41 | ) 42 | ) 43 | 44 | ;; Inverse matrix (Cofactor) 45 | 46 | (defun matrix:Inverse-Cofactor (amatrix / det) 47 | (if (not (equal 0.0 (setq det (determinant amatrix)) *tolerance*)) 48 | (mapcar (function (lambda (row) (vector:div row det))) 49 | (matrix:CofactorMatrix amatrix) 50 | ) 51 | ) 52 | ) 53 | 54 | (setq matrix:Inverse matrix:Inverse-Cofactor) -------------------------------------------------------------------------------- /linear_algebra/transform.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'transform "./linear_algebra/transform") 2 | 3 | ;;;================================================== 4 | ;;; 5 | ;;;This module include below functions 6 | ;;; 7 | ;;;================================================== 8 | ;;;(transform amatrix pt displacement) 9 | ;;;-------------------------------------------------- 10 | ;;;_$ (setq m (matrix:Inverse (translation-matrix '(100.0 100.0 100.0)))) 11 | ;;;((1.0 0.0 0.0 -100.0) (0.0 1.0 0.0 -100.0) (0.0 0.0 1.0 -100.0) (0.0 0.0 0.0 1.0)) 12 | ;;;_$ (transform m '(100.0 100.0 100.0) nil) 13 | ;;;(0.0 0.0 0.0) 14 | ;;;_$ (transform m '(100.0 100.0 100.0) T) 15 | ;;;(100.0 100.0 100.0) 16 | ;;;================================================== 17 | 18 | ;;; +------------------------------------------------------+ 19 | ;;; Copyright (c) 2020 manual chair japan 20 | ;;; Released under the MIT license 21 | ;;; https://opensource.org/licenses/mit-license.php 22 | ;;; +------------------------------------------------------+ 23 | 24 | (include 'subseq "./sequences/subseq") 25 | (include 'vector "./linear_algebra/vector") 26 | 27 | (defun transform:displacement (vector) 28 | (mapcar (function (lambda (row) (vector:InnerProduct row vector))) 29 | (subseq amatrix 0 (1- (length amatrix))) 30 | ) 31 | ) 32 | 33 | (defun transform:coordinate:adjust (size) 34 | (if (< size dimension) 35 | (cons 0.0 (transform:coordinate:adjust (1+ size))) 36 | (list 1.0) 37 | ) 38 | ) 39 | 40 | (defun transform:coordinate (point / dimension a) 41 | (setq dimension (1- (length (car amatrix))) 42 | a (append point (transform:coordinate:adjust (length point))) 43 | ) 44 | (mapcar (function (lambda (row) (vector:InnerProduct row a))) 45 | (subseq amatrix 0 (1- (length amatrix))) 46 | ) 47 | ) 48 | 49 | (defun transform (amatrix pt displacement) 50 | (if (and (vl-consp amatrix) (vl-consp pt)) 51 | (if displacement 52 | (transform:displacement pt) 53 | (transform:coordinate pt) 54 | ) 55 | (exit) 56 | ) 57 | ) 58 | -------------------------------------------------------------------------------- /numbers/acos.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'acos "./numbers/acos") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (defun acos (value) (atan (sqrt (abs (- 1.0 (* value value)))) value)) 10 | -------------------------------------------------------------------------------- /numbers/acosh.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'acosh "./numbers/acosh") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (defun acosh (y) 10 | (log (+ y (sqrt (- (expt y 2.0) 1.0)))) 11 | ) -------------------------------------------------------------------------------- /numbers/asin.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'asin "./numbers/asin") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (defun asin (num) (atan num (sqrt (abs (- 1.0 (* num num)))))) 10 | -------------------------------------------------------------------------------- /numbers/asinh.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'asinh "./numbers/asinh") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (defun asinh (y) (log (+ y (sqrt (+ (expt y 2.0) 1.0))))) 10 | -------------------------------------------------------------------------------- /numbers/atanh.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'atanh "./numbers/atanh") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (defun atanh (y) (/ (log (/ (+ 1.0 y) (- 1.0 y))) 2.0)) 10 | -------------------------------------------------------------------------------- /numbers/bitlist.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'bitlist "./numbers/bitlist") 2 | 3 | ;;;(bitlist integer) 4 | ;;; 5 | ;;;integer : integer 6 | ;;; 7 | ;;;return : list 8 | 9 | ;;; +------------------------------------------------------+ 10 | ;;; Copyright (c) 2020 manual chair japan 11 | ;;; Released under the MIT license 12 | ;;; https://opensource.org/licenses/mit-license.php 13 | ;;; +------------------------------------------------------+ 14 | 15 | ;;;_$ (bitlist 134565) 16 | ;;;(1 4 32 128 256 1024 2048 131072) 17 | 18 | (include 'integerp "./numbers/integerp") 19 | 20 | (defun bitlist (integer) 21 | (if (and (integerp integer) (not (minusp integer))) 22 | (vl-remove 0 23 | (mapcar (function (lambda (i) (logand i integer))) 24 | ;; (mapcar (function (lambda (shift) (lsh 1 shift))) (range 0 31 1)) 25 | ' 26 | (1 2 4 8 16 27 | 32 64 128 256 512 28 | 1024 2048 4096 8192 16384 29 | 32768 65536 131072 262144 524288 30 | 1048576 2097152 4194304 8388608 16777216 31 | 33554432 67108864 134217728 268435456 32 | 536870912 1073741824 33 | ) 34 | ) 35 | ) 36 | (exit) 37 | ) 38 | ) 39 | 40 | ;;;(setq bitlist acet-calc-bitlist) 41 | -------------------------------------------------------------------------------- /numbers/bittest.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'bittest "./numbers/bittest") 2 | 3 | ;;;(bittest integer bit) 4 | ;;; 5 | ;;;integer : integer 6 | ;;; 7 | ;;;bit : integer 8 | ;;; 9 | ;;;return : T or nil 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | ;;;_$ (bitlist 134565) 18 | ;;;(1 4 32 128 256 1024 2048 131072) 19 | ;;;_$ (bittest 134565 1024) 20 | ;;;T 21 | ;;;_$ (bittest 134565 65536) 22 | ;;;nil 23 | 24 | (include 'integerp "./numbers/integerp") 25 | 26 | (defun bittest (integer bit) 27 | (if (and (integerp integer) (integerp bit) (not (minusp bit))) 28 | (= (logand integer bit) bit) 29 | (exit) 30 | ) 31 | ) -------------------------------------------------------------------------------- /numbers/ceiling.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'ceiling "./numbers/ceiling") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (ceiling 100 nil) 10 | ;;;100 11 | ;;;_$ (ceiling 1.6 nil) 12 | ;;;2 13 | ;;;_$ (ceiling -1.6 nil) 14 | ;;;-1 15 | ;;;_$ (ceiling 100 2) 16 | ;;;50 17 | ;;;_$ (ceiling 1.6 2) 18 | ;;;1 19 | ;;;_$ (ceiling -1.6 2) 20 | ;;;0 21 | 22 | (include 'default "./common/default") 23 | (include 'plusp "./numbers/plusp") 24 | 25 | (defun ceiling (number divisor / quotient trunc) 26 | (setq quotient (/ number (float (default divisor 1)))) 27 | (if (= (setq trunc (fix quotient)) quotient) 28 | trunc 29 | (+ trunc 30 | (if (plusp quotient) 31 | 1 32 | 0 33 | ) 34 | ) 35 | ) 36 | ) 37 | -------------------------------------------------------------------------------- /numbers/compound.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'compound "./numbers/compound") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (compound 0 10 0) 10 | ;;;0.0 11 | ;;;_$ (compound 0 10 1) 12 | ;;;10.0 13 | ;;;_$ (compound 0 10 0.2) 14 | ;;;2.0 15 | 16 | (defun compound (number1 number2 ratio) 17 | (+ (* number1 (- 1.0 ratio)) (* number2 (float ratio))) 18 | ) 19 | -------------------------------------------------------------------------------- /numbers/cosh.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'cosh "./numbers/cosh") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (defun cosh (x) 10 | (/ (+ (exp x) (exp (- x))) 2.0) 11 | ) -------------------------------------------------------------------------------- /numbers/evenp.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'evenp "./numbers/evenp") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (evenp 1) 10 | ;;;nil 11 | ;;;_$ (evenp 2) 12 | ;;;T 13 | ;;;_$ (evenp -1) 14 | ;;;nil 15 | 16 | (include 'integerp "./numbers/integerp") 17 | 18 | (defun evenp (integer) 19 | (if (integerp integer) 20 | (zerop (logand integer 1)) 21 | (exit) 22 | ) 23 | ) -------------------------------------------------------------------------------- /numbers/floor.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'floor "./numbers/floor") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (floor 100 nil) 10 | ;;;100 11 | ;;;_$ (floor 1.6 nil) 12 | ;;;1 13 | ;;;_$ (floor -1.6 nil) 14 | ;;;-2 15 | ;;;_$ (floor 100 2) 16 | ;;;50 17 | ;;;_$ (floor 1.6 2) 18 | ;;;0 19 | ;;;_$ (floor -1.6 2) 20 | ;;;-1 21 | 22 | (include 'default "./common/default") 23 | 24 | (defun floor (number divisor / quotient trunc) 25 | (setq quotient (/ number (float (default divisor 1)))) 26 | (if (= (setq trunc (fix quotient)) quotient) 27 | trunc 28 | (- trunc 29 | (if (minusp quotient) 30 | 1 31 | 0 32 | ) 33 | ) 34 | ) 35 | ) 36 | -------------------------------------------------------------------------------- /numbers/integerp.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'integerp "./numbers/integerp") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'typep "./types/typep") 10 | 11 | (defun integerp (x) (typep x 'INT)) -------------------------------------------------------------------------------- /numbers/lcm.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'lcm "./numbers/lcm") 2 | 3 | ;;;Returns the least common multiple of two integers 4 | 5 | ;;; +------------------------------------------------------+ 6 | ;;; Copyright (c) 2020 manual chair japan 7 | ;;; Released under the MIT license 8 | ;;; https://opensource.org/licenses/mit-license.php 9 | ;;; +------------------------------------------------------+ 10 | 11 | ;;;_$ (lcm 12 18) 12 | ;;;36 13 | ;;;_$ (lcm 18 24) 14 | ;;;72 15 | ;;;_$ (lcm 60 48) 16 | ;;;240 17 | ;;;_$ (lcm 84 70) 18 | ;;;420 19 | ;;;_$ (lcm 36 72) 20 | ;;;72 21 | 22 | (defun lcm (integer1 integer2) 23 | (/ (* integer1 integer2) (gcd integer1 integer2)) 24 | ) -------------------------------------------------------------------------------- /numbers/log-b.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'log-b "./numbers/log-b") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (defun log-b (number base) (/ (log number) (log base))) -------------------------------------------------------------------------------- /numbers/mod.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'mod "./numbers/mod") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (mod 5 3) ;_ (3 * 1) + [ 2 ] 10 | ;;;2 11 | ;;;_$ (mod -5 3) ;_ (3 * 2) + [ 1 ] 12 | ;;;1 13 | ;;;_$ (rem -5 3) ;_ (3 * 1) + [ -2 ] 14 | ;;;-2 15 | 16 | (include 'floor "./numbers/floor") 17 | 18 | (defun mod (number1 number2) 19 | (- number1 (* (floor (/ (float number1) number2) nil) number2)) 20 | ) 21 | -------------------------------------------------------------------------------- /numbers/oddp.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'oddp "./numbers/oddp") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (oddp 1) 10 | ;;;T 11 | ;;;_$ (oddp 2) 12 | ;;;nil 13 | ;;;_$ (oddp -1) 14 | ;;;T 15 | 16 | (include 'integerp "./numbers/integerp") 17 | 18 | (defun oddp (integer) 19 | (if (integerp integer) 20 | (not (zerop (logand integer 1))) 21 | (exit) 22 | ) 23 | ) -------------------------------------------------------------------------------- /numbers/parse-integer-list.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'parse-integer-list "./numbers/parse-integer-list") 2 | 3 | ;;;(parse-integer-list alist start end radix junk-allowed) 4 | ;;; 5 | ;;;alist : list 6 | ;;; 7 | ;;;start : integer or nil 8 | ;;; 9 | ;;;end : integer or nil 10 | ;;; 11 | ;;;radix : integer (2~36) or if nil 10 12 | ;;; 13 | ;;;junk-allowed : T or nil 14 | ;;; 15 | ;;;return : integer 16 | 17 | ;;; +------------------------------------------------------+ 18 | ;;; Copyright (c) 2020 manual chair japan 19 | ;;; Released under the MIT license 20 | ;;; https://opensource.org/licenses/mit-license.php 21 | ;;; +------------------------------------------------------+ 22 | 23 | ;;;_$ (parse-integer-list (vl-string->list "FFFF") nil nil 16 T) 24 | ;;;65535 25 | ;;;_$ (parse-integer-list (vl-string->list "FFFF") 2 nil 16 T) 26 | ;;;255 27 | ;;;_$ (parse-integer-list (vl-string->list "FFFF") 2 3 16 T) 28 | ;;;15 29 | ;;;_$ (parse-integer-list (vl-string->list "100yen") nil nil nil T) 30 | ;;;100 31 | ;;;_$ (parse-integer-list (vl-string->list "100yen") nil nil nil nil) 32 | ;;;; �G���[: quit / exit �ɂ�钆�~ 33 | 34 | (include 'default "./common/default") 35 | (include 'scope-p "./common/scope-p") 36 | (include 'digit-char-p "./characters/digit-char-p") 37 | (include 'subseq-list "./sequences/subseq-list") 38 | 39 | (defun parse-integer:sub (clist value / this next) 40 | (if (setq this (digit-char-p (car clist) radix)) 41 | (if (and (setq value (+ (* value radix) this)) 42 | (cdr clist) 43 | (setq next (parse-integer:sub (cdr clist) value)) 44 | ) 45 | next 46 | value 47 | ) 48 | (if junk-allowed 49 | nil 50 | (exit) 51 | ) 52 | ) 53 | ) 54 | 55 | (defun parse-integer-list 56 | (alist start end radix junk-allowed / sign value) 57 | (setq start (max 0 (default start 0)) 58 | end (min (default end '(length alist)) (length alist)) 59 | radix (default radix 10) 60 | sign (default 61 | (cond ((= (car alist) (ascii "-")) (setq alist (cdr alist)) -1) 62 | ((= (car alist) (ascii "+")) (setq alist (cdr alist)) 1) 63 | ) 64 | '1 65 | ) 66 | ) 67 | (if 68 | (and alist 69 | (and (integerp radix) (scope-p radix 2 36)) 70 | (setq value (parse-integer:sub (subseq-list alist start end) 0)) 71 | ) 72 | (* sign value) 73 | (exit) 74 | ) 75 | ) -------------------------------------------------------------------------------- /numbers/parse-integer.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'parse-integer "./numbers/parse-integer") 2 | 3 | ;;;(parse-integer astring start end radix junk-allowed) 4 | ;;; 5 | ;;;astring : string, list, symbol, variant(string or safe-array), safe-array(integer) 6 | ;;; 7 | ;;;start : integer or nil 8 | ;;; 9 | ;;;end : integer or nil 10 | ;;; 11 | ;;;radix : integer (2~36) or if nil 10 12 | ;;; 13 | ;;;junk-allowed : T or nil 14 | ;;; 15 | ;;;return : integer 16 | 17 | ;;; +------------------------------------------------------+ 18 | ;;; Copyright (c) 2020 manual chair japan 19 | ;;; Released under the MIT license 20 | ;;; https://opensource.org/licenses/mit-license.php 21 | ;;; +------------------------------------------------------+ 22 | 23 | ;;;_$ (parse-integer "100yen" nil nil nil T) 24 | ;;;100 25 | ;;;_$ (parse-integer "100yen" nil nil nil nil) 26 | ;;;; error: quit / exit abort 27 | ;;;_$ (parse-integer "100yen" nil 3 nil nil) 28 | ;;;100 29 | ;;;_$ (parse-integer "ffff" nil nil 16 nil) 30 | ;;;65535 31 | ;;;_$ (parse-integer "abcd" nil nil nil T) 32 | ;;;nil 33 | 34 | (include 'stringp-list "./strings/_stringp-list") 35 | (include 'parse-integer-list "./numbers/parse-integer-list") 36 | 37 | (defun parse-integer (astring start end radix junk-allowed) 38 | (parse-integer-list (stringp-list astring) start end radix junk-allowed) 39 | ) 40 | -------------------------------------------------------------------------------- /numbers/plusp.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'plusp "./numbers/plusp") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (defun plusp (x) 10 | (if (numberp x) 11 | (< 0 x) 12 | (exit) 13 | ) 14 | ) -------------------------------------------------------------------------------- /numbers/random.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'random "./numbers/random") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'default "./common/default") 10 | (include 'type-of "./types/type-of") 11 | (include 'coerce "./types/coerce") 12 | (include 'plusp "./numbers/plusp") 13 | (include 'integerp "./numbers/integerp") 14 | 15 | ;;;Integer Max Value = 2147483647 16 | ;;;Integer Min Value = -2147483648 17 | 18 | (setq *random:integer-range* 19 | (- (float 2147483647) (float -2147483648)) 20 | *random-state* 21 | (fix (rem (* 86400 (getvar "DATE")) *random:integer-range*) 22 | ) 23 | ) 24 | 25 | (defun random (limit state) 26 | (if 27 | (and (numberp limit) (plusp limit) (or (null state) (integerp state))) 28 | (coerce (* (/ limit *random:integer-range*) 29 | (+ (float (setq *random-state* 30 | (1+ (* (default state *random-state*) 69069)) 31 | ) 32 | ) 33 | 2147483648.0 34 | ) 35 | ) 36 | (type-of limit) 37 | ) 38 | (exit) 39 | ) 40 | ) 41 | 42 | -------------------------------------------------------------------------------- /numbers/realp.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'realp "./numbers/realp") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'typep "./types/typep") 10 | 11 | (defun realp (x) (typep x 'REAL)) -------------------------------------------------------------------------------- /numbers/round-off.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'round-off "./numbers/round-off") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (round-off 1234.5678 0) 10 | ;;;1235.0 11 | ;;;_$ (round-off -1234.5678 0) 12 | ;;;-1235.0 13 | ;;;_$ (round-off -1234.5678 2) 14 | ;;;-1234.57 15 | ;;;_$ (round-off -1234.5678 -2) 16 | ;;;-1200.0 17 | 18 | (include 'signum "./numbers/signum") 19 | (include 'integerp "./numbers/integerp") 20 | 21 | (defun round-off:main (/ shift) 22 | (setq shift (expt 10.0 (fix digit))) 23 | (/ (fix (+ (* number shift) (* (signum number) 0.5))) shift) 24 | ) 25 | 26 | (defun round-off (number digit) 27 | (if (and (numberp number) (integerp digit)) 28 | (round-off:main) 29 | (exit) 30 | ) 31 | ) -------------------------------------------------------------------------------- /numbers/signum.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'signum "./numbers/signum") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (signum 2.5) 10 | ;;;1.0 11 | ;;;_$ (signum 0.0) 12 | ;;;0.0 13 | ;;;_$ (signum -2.5) 14 | ;;;-1.0 15 | ;;;_$ (signum 2) 16 | ;;;1 17 | 18 | (include 'coerce "./types/coerce") 19 | (include 'type-of "./types/type-of") 20 | 21 | (defun signum (number) 22 | (if (numberp number) 23 | (coerce (cond ((< 0 number) 1) 24 | ((< number 0) -1) 25 | (T 0) 26 | ) 27 | (type-of number) 28 | ) 29 | (exit) 30 | ) 31 | ) -------------------------------------------------------------------------------- /numbers/sinh.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'sinh "./numbers/sinh") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (defun sinh (x) 10 | (/ (- (exp x) (exp (- x))) 2.0) 11 | ) 12 | -------------------------------------------------------------------------------- /numbers/tan.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'tan "./numbers/tan") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (defun tan (radian) (/ (sin radian) (cos radian))) 10 | 11 | ;;;(setq tan acet-calc-tan) 12 | -------------------------------------------------------------------------------- /numbers/tanh.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'tanh "./numbers/tanh") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'sinh "./numbers/sinh") 10 | (include 'cosh "./numbers/cosh") 11 | 12 | (defun tanh (x) 13 | (/ (sinh x) (cosh x)) 14 | ) -------------------------------------------------------------------------------- /numbers/truncate.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'truncate "./numbers/truncate") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | ;;;_$ (truncate 100 nil) 10 | ;;;100 11 | ;;;_$ (truncate 1.6 nil) 12 | ;;;1 13 | ;;;_$ (truncate -1.6 nil) 14 | ;;;-1 15 | ;;;_$ (truncate 100 2) 16 | ;;;50 17 | ;;;_$ (truncate 1.6 2) 18 | ;;;0 19 | ;;;_$ (truncate -1.6 2) 20 | ;;;0 21 | 22 | (include 'default "./common/default") 23 | 24 | (defun truncate (number divisor / quotient trunc) 25 | (fix (/ number (float (default divisor 1)))) 26 | ) 27 | -------------------------------------------------------------------------------- /printer/_format-control-code.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'format:tilde "./printer/_format-control-code") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'default "./common/default") 10 | (include 'make-list "./conses/make-list") 11 | (include 'make-string "./strings/make-string") 12 | (include 'plusp "./numbers/plusp") 13 | 14 | (defun format:line-feed (modifier number) 15 | (setq number (default (eval number) 1)) 16 | (if (plusp number) 17 | (make-string number 10 ;| LF "\n"|;) 18 | "" 19 | ) 20 | ) 21 | 22 | ;;;_$ (format nil "~%" nil) 23 | ;;;"\n" 24 | ;;;_$ (format nil "~5%" nil) 25 | ;;;"\n\n\n\n\n" 26 | 27 | (defun format:fresh-line (modifier number) 28 | (setq number (default (eval number) 1)) 29 | (if (plusp number) 30 | (make-string 31 | (if (zerop cursor) 32 | (1- number) 33 | number 34 | ) 35 | 10 ;| LF "\n"|; 36 | ) 37 | "" 38 | ) 39 | ) 40 | 41 | ;;;_$ (format nil "~&" nil) 42 | ;;;"" 43 | ;;;_$ (format nil "ABCD~&" nil) 44 | ;;;"ABCD\n" 45 | ;;;_$ (format nil "~5&" nil) 46 | ;;;"\n\n\n\n" 47 | ;;;_$ (format nil "ABCD~5&" nil) 48 | ;;;"ABCD\n\n\n\n\n" 49 | 50 | (defun format:page-feed (modifier number) 51 | (setq number (default (eval number) 1)) 52 | (if (plusp number) 53 | (make-string number 12 ;| FF |;) 54 | "" 55 | ) 56 | ) 57 | 58 | ;;;_$ (format nil "~|" nil) 59 | ;;;"\014" 60 | ;;;_$ (format nil "~5|" nil) 61 | ;;;"\014\014\014\014\014" 62 | 63 | (defun format:tilde (modifier number) 64 | (setq number (default (eval number) 1)) 65 | (if (plusp number) 66 | (make-string (default (eval number) 1) 126 ;| "~" |;) 67 | "" 68 | ) 69 | ) 70 | 71 | ;;;_$ (format nil "~~" nil) 72 | ;;;"~" 73 | ;;;_$ (format nil "~5~" nil) 74 | ;;;"~~~~~" 75 | -------------------------------------------------------------------------------- /printer/_format-integer-grouping.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'format:integer:grouping "./printer/_format-integer-grouping") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'endp "./conses/endp") 10 | (include 'digit-char-p "./characters/digit-char-p") 11 | 12 | (defun format:integer:grouping:sub (alist index) 13 | (if (not (endp alist)) 14 | (if (digit-char-p (cadr alist) radix) 15 | (cons (car alist) 16 | (if (zerop (setq index (1- index))) 17 | (cons comma-code 18 | (format:integer:grouping:sub (cdr alist) comma-interval) 19 | ) 20 | (format:integer:grouping:sub (cdr alist) index) 21 | ) 22 | ) 23 | alist 24 | ) 25 | ) 26 | ) 27 | 28 | (defun format:integer:grouping (alist comma-code comma-interval) 29 | (reverse (format:integer:grouping:sub (reverse alist) comma-interval)) 30 | ) -------------------------------------------------------------------------------- /printer/_format-wondows-registry.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'registry:getGrouping "./printer/_format-wondows-registry") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'word "./strings/word") 10 | 11 | (setq *registry:internationalKey* 12 | "HKEY_CURRENT_USER\\Control Panel\\International" 13 | ) 14 | 15 | (defun registry:getDecimal () 16 | (ascii (vl-registry-read *registry:internationalKey* "sDecimal")) 17 | ) 18 | 19 | (defun registry:getThousand () 20 | (ascii (vl-registry-read *registry:internationalKey* "sThousand")) 21 | ) 22 | 23 | (defun registry:getGrouping (/ group) 24 | (setq group 25 | (word 'STR 26 | (vl-registry-read *registry:internationalKey* "sGrouping") 27 | ";" 28 | nil 29 | nil 30 | nil 31 | nil 32 | ) 33 | ) 34 | (atoi (cond ((= (length group) 2) (car group)) 35 | ((= (length group) 3) (cadr group)) 36 | (T "0") 37 | ) 38 | ) 39 | ) 40 | -------------------------------------------------------------------------------- /sequences/_sequence-type-of.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'sequence-type-of "./sequences/_sequence-type-of") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'type-of "./types/type-of") 10 | (include 'multi-byte-char-p "./types/multibyte/multi-byte-char-p") 11 | 12 | (defun sequence-type-of (sequence / stype) 13 | (setq stype (type-of sequence)) 14 | (cond ((= stype 'LIST) 15 | (if (vl-some 'multi-byte-char-p sequence) 16 | 'SLIST 17 | 'LIST 18 | ) 19 | ) 20 | (T stype) 21 | ) 22 | ) -------------------------------------------------------------------------------- /sequences/_sequencep-list.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'sequencep-list "./sequences/_sequencep-list") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'sequencep "./sequences/_sequencep") 10 | (include 'coerce "./types/coerce") 11 | 12 | (defun sequencep-list (item / itype) 13 | (if (setq itype (sequencep item)) 14 | (cond 15 | ((or (= itype 'STR) 16 | (= itype 'SYM) 17 | (and (= itype 'VARIANT) 18 | (= (vlax-variant-type item) vlax-vbString) 19 | ) 20 | ) 21 | (coerce item 'SLIST) 22 | ) 23 | ((or (= itype '(QUOTE nil)) (= itype 'LIST)) item) 24 | ((or 25 | (and (= itype 'VARIANT) (> (vlax-variant-type item) vlax-vbArray)) 26 | (= itype 'SAFEARRAY) 27 | ) 28 | (coerce item 'LIST) 29 | ) 30 | ) 31 | (exit) 32 | ) 33 | ) -------------------------------------------------------------------------------- /sequences/_sequencep.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'sequencep "./sequences/_sequencep") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'type-of "./types/type-of") 10 | 11 | (defun sequencep (item) 12 | (setq itype (type-of item)) 13 | (cond ((or (= itype 'STR) 14 | (= itype 'SYM) 15 | (= itype 'LIST) 16 | (and (= itype 'VARIANT) 17 | (or (= (vlax-variant-type item) vlax-vbString) 18 | (> (vlax-variant-type item) vlax-vbArray) 19 | ) 20 | ) 21 | (= itype 'SAFEARRAY) 22 | ) 23 | itype 24 | ) 25 | ((= itype 'NIL) '(quote nil)) 26 | ) 27 | ) -------------------------------------------------------------------------------- /sequences/affix-list.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'affix-list "./sequences/affix-list") 2 | 3 | ;;;(affix-list alist deco mode) 4 | ;;; 5 | ;;;alist : list 6 | ;;; 7 | ;;;deco : list 8 | ;;; 9 | ;;;mode : symbol ('LEFT 'RIGHT 'BOTH or nil) 10 | ;;; 11 | ;;;return : list 12 | 13 | ;;; +------------------------------------------------------+ 14 | ;;; Copyright (c) 2020 manual chair japan 15 | ;;; Released under the MIT license 16 | ;;; https://opensource.org/licenses/mit-license.php 17 | ;;; +------------------------------------------------------+ 18 | 19 | ;;;_$ (affix-list '(A A A A) '(* *) 'LEFT) 20 | ;;;(* * A A A A) 21 | ;;;_$ (affix-list '(A A A A) '(* *) 'RIGHT) 22 | ;;;(A A A A * *) 23 | ;;;_$ (affix-list '(A A A A) '(* *) 'BOTH) 24 | ;;;(* * A A A A * *) 25 | ;;;_$ (affix-list '(A A A A) '(* *) 'nil) 26 | ;;;(* *) 27 | 28 | (include 'member-of-option-p "./common/member-of-option-p") 29 | 30 | (defun affix-list (alist deco mode) 31 | (if (member-of-option-p 'addto 'mode '(nil LEFT RIGHT BOTH)) 32 | (if mode 33 | (cond ((= mode 'LEFT) (append deco alist)) 34 | ((= mode 'RIGHT) (append alist deco)) 35 | ((= mode 'BOTH) (append deco alist deco)) 36 | ) 37 | deco 38 | ) 39 | (exit) 40 | ) 41 | ) -------------------------------------------------------------------------------- /sequences/affix.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'affix "./sequences/affix") 2 | 3 | ;;;(affix sequence deco mode) 4 | ;;; 5 | ;;;sequence : sequence 6 | ;;; 7 | ;;;deco : sequence 8 | ;;; 9 | ;;;mode : symbol ('LEFT 'RIGHT 'BOTH or nil) 10 | ;;; 11 | ;;;return : sequence 12 | ;;; 13 | ;;; sequence is STR SYM LIST VARIANT(STR SAFEARRAY) SAFEARRAY 14 | 15 | ;;; +------------------------------------------------------+ 16 | ;;; Copyright (c) 2020 manual chair japan 17 | ;;; Released under the MIT license 18 | ;;; https://opensource.org/licenses/mit-license.php 19 | ;;; +------------------------------------------------------+ 20 | 21 | ;;;_$ (affix "HAPPY" "*+*" 'LEFT) 22 | ;;;"*+*HAPPY" 23 | ;;;_$ (affix "HAPPY" "*+*" 'RIGHT) 24 | ;;;"HAPPY*+*" 25 | ;;;_$ (affix "HAPPY" "*+*" 'BOTH) 26 | ;;;"*+*HAPPY*+*" 27 | ;;;_$ (affix "HAPPY" "*+*" nil) 28 | ;;;"*+*" 29 | ;;;_$ (affix '(A A A A) '(* *) 'LEFT) 30 | ;;;(* * A A A A) 31 | 32 | (include 'coerce "./types/coerce") 33 | (include 'sequencep-list "./sequences/_sequencep-list") 34 | (include 'sequence-type-of "./sequences/_sequence-type-of") 35 | (include 'affix-list "./sequences/affix-list") 36 | 37 | (defun affix (sequence deco mode) 38 | (coerce (affix-list (sequencep-list sequence) (sequencep-list deco) mode) 39 | (sequence-type-of sequence) 40 | ) 41 | ) -------------------------------------------------------------------------------- /sequences/concatenate.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'concatenate "./sequences/concatenate") 2 | 3 | ;;;(concatenate atype list-of-sequence) 4 | ;;; 5 | ;;;atype : symbol (STR LIST SLIST SYM VARIANT SAFEARRAY VECTOR) 6 | ;;; 7 | ;;;list-of-sequence : list of sequence 8 | ;;; 9 | ;;;return : sequence 10 | ;;; 11 | ;;; sequence is STR SYM LIST VARIANT(STR SAFEARRAY) SAFEARRAY 12 | 13 | ;;; +------------------------------------------------------+ 14 | ;;; Copyright (c) 2020 manual chair japan 15 | ;;; Released under the MIT license 16 | ;;; https://opensource.org/licenses/mit-license.php 17 | ;;; +------------------------------------------------------+ 18 | 19 | ;;;_$ (concatenate 'LIST '((0 1 2 3) (A B C D))) 20 | ;;;(0 1 2 3 A B C D) 21 | ;;;_$ (concatenate 'STR '("Auto" "CAD")) 22 | ;;;"AutoCAD" 23 | ;;;_$ (concatenate 'SLIST '("Auto" "CAD")) 24 | ;;;(65 117 116 111 67 65 68) 25 | 26 | (include 'type-of "./types/type-of") 27 | (include 'coerce "./types/coerce") 28 | (include 'sequencep-list "./sequences/_sequencep-list") 29 | 30 | (defun concatenate (atype list-of-sequence) 31 | (coerce (apply 'append 32 | (mapcar (function (lambda (sequence) (sequencep-list sequence))) 33 | list-of-sequence 34 | ) 35 | ) 36 | atype 37 | ) 38 | ) -------------------------------------------------------------------------------- /sequences/count-if.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'count-if "./sequences/count-if") 2 | 3 | ;;;(count-if predicate sequence start end) 4 | ;;; 5 | ;;;predicate : predicate function 6 | ;;; function apply single argment. 7 | ;;; 8 | ;;;sequence : sequence 9 | ;;; 10 | ;;;start : integer or nil 11 | ;;; 12 | ;;;end : integer or nil 13 | ;;; 14 | ;;;return : integer 15 | ;;; 16 | ;;; sequence is STR SYM LIST VARIANT(STR SAFEARRAY) SAFEARRAY 17 | 18 | ;;; +------------------------------------------------------+ 19 | ;;; Copyright (c) 2020 manual chair japan 20 | ;;; Released under the MIT license 21 | ;;; https://opensource.org/licenses/mit-license.php 22 | ;;; +------------------------------------------------------+ 23 | 24 | ;;;_$ (count-if 'upper-case-p "ABCDabcd" nil nil) 25 | ;;;4 26 | ;;;_$ (count-if 'upper-case-p "ABCDabcd" 2 4) 27 | ;;;2 28 | 29 | (include 'sequencep-list "./sequences/_sequencep-list") 30 | (include 'count-list-if "./sequences/count-list-if") 31 | 32 | (defun count-if ($_predicate $_sequence $_start $_end) 33 | (count-list-if 34 | $_predicate 35 | (sequencep-list $_sequence) 36 | $_start 37 | $_end 38 | ) 39 | ) -------------------------------------------------------------------------------- /sequences/count-list-if.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'count-list-if "./sequences/count-list-if") 2 | 3 | ;;;(count-list-if predicate alist start end) 4 | ;;; count-list-if of only list version 5 | ;;; 6 | ;;;predicate : predicate function 7 | ;;; function apply single argment. 8 | ;;; 9 | ;;;alist : list 10 | ;;; 11 | ;;;start : integer or nil 12 | ;;; 13 | ;;;end : integer or nil 14 | ;;; 15 | ;;;return : integer 16 | 17 | ;;; +------------------------------------------------------+ 18 | ;;; Copyright (c) 2020 manual chair japan 19 | ;;; Released under the MIT license 20 | ;;; https://opensource.org/licenses/mit-license.php 21 | ;;; +------------------------------------------------------+ 22 | 23 | ;;;_$ (count-list-if 'oddp '(0 1 2 3 4 5 6 7 8 9) nil nil) 24 | ;;;5 25 | ;;;_$ (count-list-if 'oddp '(0 1 2 3 4 5 6 7 8 9) 3 6) 26 | ;;;2 27 | 28 | (include 'default "./common/default") 29 | (include 'subseq-list "./sequences/subseq-list") 30 | 31 | (defun count-list-if ($_predicate $_list $_start $_end) 32 | (setq $_start (max 0 (default $_start 0)) 33 | $_end (min (default $_end '(length $_list)) (length $_list)) 34 | ) 35 | (length (vl-remove-if-not $_predicate (subseq-list $_list $_start $_end)) 36 | ) 37 | ) -------------------------------------------------------------------------------- /sequences/count.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'count "./sequences/count") 2 | 3 | ;;;(count item sequence test-func start end) 4 | ;;; 5 | ;;;item : atom or list 6 | ;;; 7 | ;;;sequence : sequence 8 | ;;; 9 | ;;;test-func : function 10 | ;;; 11 | ;;;start : integer or nil 12 | ;;; 13 | ;;;end : integer or nil 14 | ;;; 15 | ;;;return : integer 16 | ;;; 17 | ;;; sequence is STR SYM LIST VARIANT(STR SAFEARRAY) SAFEARRAY 18 | 19 | ;;; +------------------------------------------------------+ 20 | ;;; Copyright (c) 2020 manual chair japan 21 | ;;; Released under the MIT license 22 | ;;; https://opensource.org/licenses/mit-license.php 23 | ;;; +------------------------------------------------------+ 24 | 25 | ;;;_$ (count (ascii "s") "All is well that ends well" nil nil nil) 26 | ;;;2 27 | ;;;_$ (count (ascii "s") "All is well that ends well" nil 3 7) 28 | ;;;1 29 | ;;;_$ (count (ascii "S") "Speech is silver, silence is gold" 'char-equal nil nil) 30 | ;;;5 31 | 32 | (include 'functionp "./flow/functionp") 33 | (include 'count-if "./sequences/count-if") 34 | 35 | (defun count (item sequence test-func start end) 36 | (if (functionp (eval (setq test-func (default test-func ''equal)))) 37 | (count-if 38 | (function (lambda (test-item) (apply test-func (list item test-item))) 39 | ) 40 | sequence 41 | start 42 | end 43 | ) 44 | (exit) 45 | ) 46 | ) -------------------------------------------------------------------------------- /sequences/elt.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'elt "./sequences/elt") 2 | 3 | ;;;(elt sequence n) 4 | ;;; 5 | ;;;sequence : sequence 6 | ;;; 7 | ;;;n : integer 8 | ;;; 9 | ;;;retrun : atom, or list 10 | ;;; 11 | ;;; Similar to nth function with n range checks 12 | ;;; 13 | ;;; sequence is STR SYM LIST VARIANT(STR SAFEARRAY) SAFEARRAY 14 | 15 | ;;; +------------------------------------------------------+ 16 | ;;; Copyright (c) 2020 manual chair japan 17 | ;;; Released under the MIT license 18 | ;;; https://opensource.org/licenses/mit-license.php 19 | ;;; +------------------------------------------------------+ 20 | 21 | ;;;_$ (elt '(0 1 2 3 4) 3) 22 | ;;;3 23 | ;;;_$ (elt '(0 1 2 3 4) 6) 24 | ;;;; �G���[: quit / exit �ɂ�钆�~ 25 | ;;;_$ (elt "01234" 3) 26 | ;;;51 27 | 28 | (include 'sequencep-list "./sequences/_sequencep-list") 29 | 30 | (defun elt:sub (alist) 31 | (if (and (not (minusp n)) (< n (length alist))) 32 | (nth n alist) 33 | (exit) 34 | ) 35 | ) 36 | 37 | (defun elt (sequence n) (elt:sub (sequencep-list sequence))) -------------------------------------------------------------------------------- /sequences/fill-list.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'fill-list "./sequences/fill-list") 2 | 3 | ;;;(fill-list alist item start end) 4 | ;;; 5 | ;;;alist : list 6 | ;;; 7 | ;;;item : atom or list 8 | ;;; 9 | ;;;start : integer or nil 10 | ;;; 11 | ;;;end : integer or nil 12 | ;;; 13 | ;;;retrun : list 14 | 15 | ;;; +------------------------------------------------------+ 16 | ;;; Copyright (c) 2020 manual chair japan 17 | ;;; Released under the MIT license 18 | ;;; https://opensource.org/licenses/mit-license.php 19 | ;;; +------------------------------------------------------+ 20 | 21 | ;;;_$ (fill-list '(0 1 2 3 4 5 6) '* 1 4) 22 | ;;;(0 * * * 4 5 6) 23 | ;;;_$ (fill-list '(0 1 2 3 4 5 6) '* 2 nil) 24 | ;;;(0 1 * * * * *) 25 | ;;;_$ (fill-list '(0 1 2 3 4 5 6) '* nil 3) 26 | ;;;(* * * 3 4 5 6) 27 | ;;;_$ (fill-list '(0 1 2 3 4 5 6) '* nil nil) 28 | ;;;(* * * * * * *) 29 | 30 | (include 'default "./common/default") 31 | 32 | (defun fill-list:sub (alist counter) 33 | (if (< counter end) 34 | (cons (if (<= start counter) 35 | item 36 | (car alist) 37 | ) 38 | (fill-list:sub (cdr alist) (1+ counter)) 39 | ) 40 | alist 41 | ) 42 | ) 43 | 44 | (defun fill-list (alist item start end) 45 | (setq start (max 0 (default start 0)) 46 | end (min (default end '(length alist)) (length alist)) 47 | ) 48 | (fill-list:sub alist 0) 49 | ) -------------------------------------------------------------------------------- /sequences/fill.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'fill "./sequences/fill") 2 | 3 | ;;;(fill sequence item start end) 4 | ;;; 5 | ;;;sequence : sequence 6 | ;;; 7 | ;;;item : atom or list 8 | ;;; 9 | ;;;start : integer or nil 10 | ;;; 11 | ;;;end : integer or nil 12 | ;;; 13 | ;;;return : sequence 14 | ;;; 15 | ;;; sequence is STR SYM LIST VARIANT(STR SAFEARRAY) SAFEARRAY 16 | 17 | ;;; +------------------------------------------------------+ 18 | ;;; Copyright (c) 2020 manual chair japan 19 | ;;; Released under the MIT license 20 | ;;; https://opensource.org/licenses/mit-license.php 21 | ;;; +------------------------------------------------------+ 22 | 23 | ;;;_$ (fill '(0 1 2 3 4 5 6) '* 1 4) 24 | ;;;(0 * * * 4 5 6) 25 | ;;;_$ (fill '(0 1 2 3 4 5 6) '* 2 nil) 26 | ;;;(0 1 * * * * *) 27 | ;;;_$ (fill '(0 1 2 3 4 5 6) '* nil 3) 28 | ;;;(* * * 3 4 5 6) 29 | ;;;_$ (fill '(0 1 2 3 4 5 6) '* nil nil) 30 | ;;;(* * * * * * *) 31 | ;;;_$ (fill "ABCDEFG" (ascii "*") 1 4) 32 | ;;;"A***EFG" 33 | 34 | (include 'coerce "./types/coerce") 35 | (include 'sequencep-list "./sequences/_sequencep-list") 36 | (include 'sequence-type-of "./sequences/_sequence-type-of") 37 | (include 'fill-list "./sequences/fill-list") 38 | 39 | (defun fill (sequence item start end) 40 | (coerce (fill-list (sequencep-list sequence) item start end) 41 | (sequence-type-of sequence) 42 | ) 43 | ) -------------------------------------------------------------------------------- /sequences/map.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'map "./sequences/map") 2 | 3 | ;;;(map type function list-of-sequence) 4 | ;;; 5 | ;;;type : symbol (STR LIST SLIST SYM VARIANT SAFEARRAY VECTOR) 6 | ;;; 7 | ;;;function : function 8 | ;;; 9 | ;;;list-of-sequence : list of sequence 10 | ;;; 11 | ;;;retrun : atom, or list 12 | ;;; 13 | ;;; sequence is STR SYM LIST VARIANT(STR SAFEARRAY) SAFEARRAY 14 | 15 | ;;; +------------------------------------------------------+ 16 | ;;; Copyright (c) 2020 manual chair japan 17 | ;;; Released under the MIT license 18 | ;;; https://opensource.org/licenses/mit-license.php 19 | ;;; +------------------------------------------------------+ 20 | 21 | 22 | ;;;_$ (map 'STR 'char-upcase (list "abcdefg")) 23 | ;;;"ABCDEFG" 24 | ;;;_$ (map 'LIST '+ (list '(0 1 2 3 4) '(4 3 2 1 0))) 25 | ;;;(4 4 4 4 4) 26 | ;;;_$ (map 'ARRAY '+ (list '(0 1 2 3 4) '(4 3 2 1 0))) 27 | ;;;# 28 | 29 | (include 'sequencep-list "./sequences/_sequencep-list") 30 | 31 | (defun map ($_type $_function $_list-of-sequence) 32 | (coerce (apply 'mapcar 33 | (cons $_function 34 | (mapcar (function (lambda (seq) (sequencep-list seq))) 35 | $_list-of-sequence 36 | ) 37 | ) 38 | ) 39 | $_type 40 | ) 41 | ) -------------------------------------------------------------------------------- /sequences/padding.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'padding "./sequences/padding") 2 | 3 | ;;;(padding sequence mode width overflow pad) 4 | ;;; 5 | ;;;sequence : sequence 6 | ;;; 7 | ;;;mode : symbol ('LEFT 'RIGHT 'BOTH) 8 | ;;; 9 | ;;;width : integer 10 | ;;; 11 | ;;;overflow , pad : atom or list 12 | ;;; 13 | ;;;retrun : sequence 14 | ;;; 15 | ;;; sequence is STR SYM LIST VARIANT(STR SAFEARRAY) SAFEARRAY 16 | 17 | ;;; +------------------------------------------------------+ 18 | ;;; Copyright (c) 2020 manual chair japan 19 | ;;; Released under the MIT license 20 | ;;; https://opensource.org/licenses/mit-license.php 21 | ;;; +------------------------------------------------------+ 22 | 23 | ;;;_$ (padding "10.0" 'LEFT 7 nil (ascii "*")) 24 | ;;;"***10.0" 25 | ;;;_$ (padding "10.0" 'RIGHT 7 nil (ascii "*")) 26 | ;;;"10.0***" 27 | ;;;_$ (padding "10.0" 'BOTH 7 nil (ascii "*")) 28 | ;;;"*10.0*" 29 | ;;;_$ (padding "10.0" 'LEFT 3 nil (ascii "*")) 30 | ;;;"0.0" 31 | ;;;_$ (padding "10.0" 'LEFT 3 (ascii "#") (ascii "*")) 32 | ;;;"###" 33 | 34 | (include 'default "./common/default") 35 | (include 'coerce "./types/coerce") 36 | (include 'sequencep-list "./sequences/_sequencep-list") 37 | (include 'sequence-type-of "./sequences/_sequence-type-of") 38 | (include 'padding-list "./sequences/padding-list") 39 | 40 | (defun padding (sequence mode width overflow pad) 41 | (coerce (padding-list 42 | (sequencep-list sequence) 43 | mode 44 | width 45 | overflow 46 | (default pad '(ascii " ")) 47 | ) 48 | (sequence-type-of sequence) 49 | ) 50 | ) 51 | -------------------------------------------------------------------------------- /sequences/position-if.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'position-if "./sequences/position-if") 2 | 3 | ;;;(position-if predicate sequence start end from-end) 4 | ;;; 5 | ;;;predicate : predicate function 6 | ;;; function apply single argment. 7 | ;;; 8 | ;;;sequence : sequence 9 | ;;; 10 | ;;;start : integer or nil 11 | ;;; 12 | ;;;end : integer or nil 13 | ;;; 14 | ;;;from-end : atom (T or nil) 15 | ;;; 16 | ;;;return : integer of index(zero-indexed) or nil 17 | ;;; 18 | ;;; sequence is STR SYM LIST VARIANT(STR SAFEARRAY) SAFEARRAY 19 | 20 | ;;; +------------------------------------------------------+ 21 | ;;; Copyright (c) 2020 manual chair japan 22 | ;;; Released under the MIT license 23 | ;;; https://opensource.org/licenses/mit-license.php 24 | ;;; +------------------------------------------------------+ 25 | 26 | ;;;_$ (position-if 'oddp '(0 1 2 3 4 5 0 1 2 3 4 5) nil nil nil) 27 | ;;;1 28 | ;;;_$ (position-if 'zerop '(0 1 2 3 4 5 0 1 2 3 4 5) 3 nil nil) 29 | ;;;6 30 | ;;;_$ (position-if 'zerop '(0 1 2 3 4 5 0 1 2 3 4 5) nil nil T) 31 | ;;;6 32 | ;;;_$ (position-if (function (lambda (item) (= item (ascii "a")))) "This is a pen" nil nil nil) 33 | ;;;8 34 | 35 | (include 'sequencep-list "./sequences/_sequencep-list") 36 | (include 'position-list-if "./sequences/position-list-if") 37 | 38 | (defun position-if ($_predicate $_sequence $_start $_end $_from-end) 39 | (position-list-if 40 | $_predicate 41 | (sequencep-list $_sequence) 42 | $_start 43 | $_end 44 | $_from-end 45 | ) 46 | ) 47 | -------------------------------------------------------------------------------- /sequences/position-list-if.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'position-list-if "./sequences/position-list-if") 2 | 3 | ;;;(position-list-if predicate list start end from-end) 4 | ;;; position-if of only list version 5 | ;;; 6 | ;;;predicate : predicate function 7 | ;;; function apply single argment. 8 | ;;; 9 | ;;;list : list 10 | ;;; 11 | ;;;start : integer or nil 12 | ;;; 13 | ;;;end : integer or nil 14 | ;;; 15 | ;;;from-end : atom (T or nil) 16 | ;;; 17 | ;;;return : integer of index(zero-indexed) or nil 18 | 19 | ;;; +------------------------------------------------------+ 20 | ;;; Copyright (c) 2020 manual chair japan 21 | ;;; Released under the MIT license 22 | ;;; https://opensource.org/licenses/mit-license.php 23 | ;;; +------------------------------------------------------+ 24 | 25 | ;;;_$ (position-list-if 'oddp '(0 1 2 3 4 5 0 1 2 3 4 5) nil nil nil) 26 | ;;;1 27 | ;;;_$ (position-list-if 'zerop '(0 1 2 3 4 5 0 1 2 3 4 5) 3 nil nil) 28 | ;;;6 29 | ;;;_$ (position-list-if 'zerop '(0 1 2 3 4 5 0 1 2 3 4 5) nil nil T) 30 | ;;;6 31 | 32 | (include 'default "./common/default") 33 | (include 'subseq-list "./sequences/subseq-list") 34 | 35 | (defun position:find ($_target $_index) 36 | (if $_target 37 | (if (apply $_predicate (list (car $_target))) 38 | $_index 39 | (position:find (cdr $_target) (1+ $_index)) 40 | ) 41 | ) 42 | ) 43 | 44 | (defun position-list-if 45 | ($_predicate $_list $_start $_end $_from-end / $_index) 46 | (setq $_start (max 0 (default $_start '0)) 47 | $_end (min (default $_end '(length $_list)) (length $_list)) 48 | $_index (position:find 49 | (if $_from-end 50 | (reverse (subseq-list $_list $_start $_end)) 51 | (subseq-list $_list $_start $_end) 52 | ) 53 | 0 54 | ) 55 | ) 56 | (if $_index 57 | (if $_from-end 58 | (- $_end $_index 1) 59 | (+ $_start $_index) 60 | ) 61 | ) 62 | ) 63 | -------------------------------------------------------------------------------- /sequences/position.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'position "./sequences/position") 2 | 3 | ;;;(position item sequence test-func start end from-end) 4 | ;;; 5 | ;;;item : atom or list 6 | ;;; 7 | ;;;sequence : sequence 8 | ;;; 9 | ;;;test-func : function 10 | ;;; 11 | ;;;start : integer or nil 12 | ;;; 13 | ;;;end : integer or nil 14 | ;;; 15 | ;;;from-end : atom (T or nil) 16 | ;;; 17 | ;;;return : integer of index(zero-indexed) or nil 18 | ;;; 19 | ;;; sequence is STR SYM LIST VARIANT(STR SAFEARRAY) SAFEARRAY 20 | 21 | ;;; +------------------------------------------------------+ 22 | ;;; Copyright (c) 2020 manual chair japan 23 | ;;; Released under the MIT license 24 | ;;; https://opensource.org/licenses/mit-license.php 25 | ;;; +------------------------------------------------------+ 26 | 27 | ;;;_$ (position 4 '(0 1 2 3 4 5 0 1 2 3 4 5) nil nil nil nil) 28 | ;;;4 29 | ;;;_$ (position 4 '(0 1 2 3 4 5 0 1 2 3 4 5) nil 5 nil nil) 30 | ;;;10 31 | ;;;_$ (position 4 '(0 1 2 3 4 5 0 1 2 3 4 5) nil nil nil T) 32 | ;;;10 33 | ;;;_$ (position 4 '(0 1 2 3 4 5 0 1 2 3 4 5) nil nil 5 T) 34 | ;;;4 35 | ;;;_$ (position (ascii "C") "ABCDEF" nil nil nil nil) 36 | ;;;2 37 | 38 | (include 'functionp "./flow/functionp") 39 | (include 'position-if "./sequences/position-if") 40 | 41 | (defun position (item sequence test-func start end from-end) 42 | (if (functionp (eval (setq test-func (default test-func ''equal)))) 43 | (position-if 44 | (function (lambda (test-item) (apply test-func (list item test-item))) 45 | ) 46 | sequence 47 | start 48 | end 49 | from-end 50 | ) 51 | (exit) 52 | ) 53 | ) -------------------------------------------------------------------------------- /sequences/prioritize-list.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'prioritize-list "./sequences/prioritize-list") 2 | 3 | ;;;(prioritize-list alist index advance) 4 | ;;; 5 | ;;;alist : list 6 | ;;; 7 | ;;;index advance : integer 8 | ;;; 9 | ;;;return : list 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | ;;;_$ (prioritize-list '(0 1 2) 1 1) 18 | ;;;(0 2 1) 19 | ;;;_$ (prioritize-list '(0 1 2) 1 -1) 20 | ;;;(1 0 2) 21 | ;;;_$ (prioritize-list '(0 1 2) 1 0) 22 | ;;;(0 1 2) 23 | 24 | (include 'scope "./common/scope") 25 | (include 'integerp "./numbers/integerp") 26 | 27 | (defun prioritize-list:normal () 28 | (if (= current index) 29 | (prioritize-list:sub (cdr alist) (1+ current)) 30 | (cons (car alist) (prioritize-list:sub (cdr alist) (1+ current))) 31 | ) 32 | ) 33 | 34 | (defun prioritize-list:insert-normal () 35 | (cons adata (prioritize-list:normal)) 36 | ) 37 | 38 | (defun prioritize-list:insert-reverse () 39 | (if (= current index) 40 | (cons adata (prioritize-list:sub (cdr alist) (1+ current))) 41 | (cons (car alist) 42 | (cons adata (prioritize-list:sub (cdr alist) (1+ current))) 43 | ) 44 | ) 45 | ) 46 | 47 | (defun prioritize-list:sub (alist current) 48 | (if (or (<= current insert) (<= current index)) 49 | (if (= current insert) 50 | (insert-func) 51 | (prioritize-list:normal) 52 | ) 53 | alist 54 | ) 55 | ) 56 | 57 | (defun prioritize-list (alist index advance / adata insert insert-func) 58 | (if (and (integerp index) (integerp advance)) 59 | (if (zerop advance) 60 | alist 61 | (progn (setq adata (nth index alist) 62 | insert (scope (+ index advance) 0 (1- (length alist))) 63 | insert-func (if (minusp advance) 64 | prioritize-list:insert-normal 65 | prioritize-list:insert-reverse 66 | ) 67 | ) 68 | (prioritize-list:sub alist 0) 69 | ) 70 | ) 71 | (exit) 72 | ) 73 | ) -------------------------------------------------------------------------------- /sequences/prioritize.lsp: -------------------------------------------------------------------------------- 1 | ;;;(include 'prioritize "./sequences/prioritize") 2 | 3 | ;;;(prioritize sequence index advance) 4 | ;;; 5 | ;;;sequence : sequence 6 | ;;; 7 | ;;;index advance : integer 8 | ;;; 9 | ;;;return : sequence 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | ;;;_$ (prioritize '(0 1 2) 1 1) 18 | ;;;(0 2 1) 19 | ;;;_$ (prioritize '(0 1 2) 1 -1) 20 | ;;;(1 0 2) 21 | ;;;_$ (prioritize '(0 1 2) 1 0) 22 | ;;;(0 1 2) 23 | ;;;_$ (prioritize "ABC" 1 1) 24 | ;;;"ACB" 25 | ;;;_$ (prioritize "ABC" 1 -1) 26 | ;;;"BAC" 27 | ;;;_$ (prioritize "ABC" 1 0) 28 | ;;;"ABC" 29 | 30 | (include 'sequencep-list "./sequences/_sequencep-list") 31 | (include 'sequence-type-of "./sequences/_sequence-type-of") 32 | (include 'prioritize-list "./sequences/prioritize-list") 33 | 34 | (defun prioritize (sequence index advance) 35 | (coerce (prioritize-list 36 | (sequencep-list sequence) 37 | index advance 38 | ) 39 | (sequence-type-of sequence) 40 | ) 41 | ) 42 | -------------------------------------------------------------------------------- /sequences/reduce.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'reduce "./sequences/reduce") 2 | 3 | ;;;(reduce func sequence) 4 | ;;; 5 | ;;;func : function symbol or list 6 | ;;; function apply binary argments. 7 | ;;; 8 | ;;;sequence : sequence 9 | ;;; 10 | ;;;return : (func (func A B) C) 11 | ;;; 12 | ;;; sequence is STR SYM LIST VARIANT(STR SAFEARRAY) SAFEARRAY 13 | 14 | ;;; +------------------------------------------------------+ 15 | ;;; Copyright (c) 2020 manual chair japan 16 | ;;; Released under the MIT license 17 | ;;; https://opensource.org/licenses/mit-license.php 18 | ;;; +------------------------------------------------------+ 19 | 20 | (include 'recurse-binaryOperator "./evaluation/recurse-binOperator") 21 | (include 'sequencep-list "./sequences/_sequencep-list") 22 | 23 | (defun reduce (func sequence) 24 | ((recurse-binaryOperator func) (sequencep-list sequence)) 25 | ) -------------------------------------------------------------------------------- /sequences/remove-duplicates-list.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'remove-duplicates-list "./sequences/remove-duplicates-list") 2 | 3 | ;;;(remove-duplicates-list alist test-func start end from-end) 4 | ;;; 5 | ;;;alist : list 6 | ;;; 7 | ;;;test-func : function 8 | ;;; 9 | ;;;start : integer or nil 10 | ;;; 11 | ;;;end : integer or nil 12 | ;;; 13 | ;;;from-end : atom (T or nil) 14 | ;;; 15 | ;;;return : list 16 | 17 | ;;; +------------------------------------------------------+ 18 | ;;; Copyright (c) 2020 manual chair japan 19 | ;;; Released under the MIT license 20 | ;;; https://opensource.org/licenses/mit-license.php 21 | ;;; +------------------------------------------------------+ 22 | 23 | ;;;_$ (remove-duplicates-list '(0 1 2 3 4 3 4 2 4 1 4 0) nil nil nil nil) 24 | ;;;(3 2 1 4 0) 25 | ;;;_$ (remove-duplicates-list '(0 1 2 3 4 3 4 2 4 1 4 0) nil nil nil T) 26 | ;;;(0 1 2 3 4) 27 | 28 | (include 'default "./common/default") 29 | (include 'functionp "./flow/functionp") 30 | (include 'endp "./conses/endp") 31 | (include 'subseq-list "./sequences/subseq-list") 32 | 33 | (defun remove-duplicates-list:sub (alist) 34 | (if (not (endp alist)) 35 | (if (vl-member-if 36 | (function (lambda (test-item) 37 | (apply test-func (list (car alist) test-item)) 38 | ) 39 | ) 40 | (cdr alist) 41 | ) 42 | (remove-duplicates-list:sub (cdr alist)) 43 | (cons (car alist) (remove-duplicates-list:sub (cdr alist))) 44 | ) 45 | ) 46 | ) 47 | 48 | (defun remove-duplicates-list (alist test-func start end from-end) 49 | (setq start (max 0 (default start '0)) 50 | end (min (default end '(length alist)) (length alist)) 51 | ) 52 | (if (functionp (eval (setq test-func (default test-func ''equal)))) 53 | (append (subseq-list alist 0 start) 54 | (if from-end 55 | (reverse 56 | (remove-duplicates-list:sub (reverse (subseq-list alist start end))) 57 | ) 58 | (remove-duplicates-list:sub (subseq-list alist start end)) 59 | ) 60 | (subseq-list alist end nil) 61 | ) 62 | (exit) 63 | ) 64 | ) -------------------------------------------------------------------------------- /sequences/remove-duplicates.LSP: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/manualChair/commonlib/79164a197831e89b76f86d452c55688ca0d896a6/sequences/remove-duplicates.LSP -------------------------------------------------------------------------------- /sequences/remove-if.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'remove-if "./sequences/remove-if") 2 | 3 | ;;;(remove-if predicate sequence start end count from-end) 4 | ;;; 5 | ;;;predicate : predicate function 6 | ;;; function apply single argment. 7 | ;;; 8 | ;;;sequence : sequence 9 | ;;; 10 | ;;;start : integer or nil 11 | ;;; 12 | ;;;end : integer or nil 13 | ;;; 14 | ;;;count : integer or nil 15 | ;;; 16 | ;;;from-end : atom (T or nil) 17 | ;;; 18 | ;;;return : sequence 19 | ;;; 20 | ;;; sequence is STR SYM LIST VARIANT(STR SAFEARRAY) SAFEARRAY 21 | 22 | ;;; +------------------------------------------------------+ 23 | ;;; Copyright (c) 2020 manual chair japan 24 | ;;; Released under the MIT license 25 | ;;; https://opensource.org/licenses/mit-license.php 26 | ;;; +------------------------------------------------------+ 27 | 28 | ;;;_$ (remove-if (function (lambda (item) (equal item 'A))) '(a b c A B C a b) nil nil nil nil) 29 | ;;;(B C B C B) 30 | ;;;_$ (remove-if (function (lambda (item) (equal item 'A))) '(a b c A B C a b) nil nil 2 nil) 31 | ;;;(B C B C A B) 32 | ;;;_$ (remove-if (function (lambda (item) (equal item 'A))) '(a b c A B C a b) nil nil 2 T) 33 | ;;;(A B C B C B) 34 | ;;;_$ (remove-if (function (lambda (item) (equal item 'A))) '(a b c A B C a b) nil 6 2 T) 35 | ;;;(B C B C A B) 36 | ;;;_$ (remove-if (function (lambda (item) (equal item (ascii "A")))) "abcABCab" nil nil nil nil) 37 | ;;;"abcBCab" 38 | 39 | (include 'coerce "./types/coerce") 40 | (include 'sequencep-list "./sequences/_sequencep-list") 41 | (include 'sequence-type-of "./sequences/_sequence-type-of") 42 | (include 'remove-list-if "./sequences/remove-list-if") 43 | 44 | (defun remove-if ($_predicate $_sequence $_start $_end $_count $_from-end) 45 | (coerce (remove-list-if 46 | $_predicate 47 | (sequencep-list $_sequence) 48 | $_start 49 | $_end 50 | $_count 51 | $_from-end 52 | ) 53 | (sequence-type-of $_sequence) 54 | ) 55 | ) -------------------------------------------------------------------------------- /sequences/remove-repetition-list.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'remove-repetition-list "./sequences/remove-repetition-list") 2 | 3 | ;;;(remove-repetition-list alist test-func start end from-end) 4 | ;;; 5 | ;;;alist : list 6 | ;;; 7 | ;;;test-func : function 8 | ;;; 9 | ;;;start : integer or nil 10 | ;;; 11 | ;;;end : integer or nil 12 | ;;; 13 | ;;;from-end : atom (T or nil) 14 | ;;; 15 | ;;;return : list 16 | 17 | ;;; +------------------------------------------------------+ 18 | ;;; Copyright (c) 2020 manual chair japan 19 | ;;; Released under the MIT license 20 | ;;; https://opensource.org/licenses/mit-license.php 21 | ;;; +------------------------------------------------------+ 22 | 23 | ;;;_$ (remove-repetition-list '(0 0 1 1 2 2 1 2) '= nil nil nil) 24 | ;;;(0 1 2 1 2) 25 | ;;;_$ (remove-repetition-list '(0 0 1 1 2 2 1 2) '= 1 5 nil) 26 | ;;;(0 0 1 2 2 1 2) 27 | 28 | (include 'default "./common/default") 29 | (include 'functionp "./flow/functionp") 30 | (include 'endp "./conses/endp") 31 | (include 'subseq-list "./sequences/subseq-list") 32 | 33 | (defun remove-repetition-list:sub (alist) 34 | (if (not (endp alist)) 35 | (if (not (null (cdr alist))) 36 | (if (apply test-func (list (car alist) (cadr alist))) 37 | (remove-repetition-list:sub (cdr alist)) 38 | (cons (car alist) (remove-repetition-list:sub (cdr alist))) 39 | ) 40 | alist 41 | ) 42 | ) 43 | ) 44 | 45 | (defun remove-repetition-list (alist test-func start end from-end) 46 | (setq start (max 0 (default start '0)) 47 | end (min (default end '(length alist)) (length alist)) 48 | ) 49 | (if (functionp (eval (setq test-func (default test-func ''equal)))) 50 | (append (subseq-list alist 0 start) 51 | (if from-end 52 | (reverse (remove-repetition-list:sub 53 | (reverse (subseq-list alist start end)) 54 | ) 55 | ) 56 | (remove-repetition-list:sub (subseq-list alist start end)) 57 | ) 58 | (subseq-list alist end nil) 59 | ) 60 | (exit) 61 | ) 62 | ) 63 | -------------------------------------------------------------------------------- /sequences/remove-repetition.lsp: -------------------------------------------------------------------------------- 1 | ;;;(include 'remove-repetition "./sequences/remove-repetition") 2 | 3 | ;;;(remove-repetition sequence test-func start end from-end) 4 | ;;; 5 | ;;;sequence : sequence 6 | ;;; 7 | ;;;test-func : function 8 | ;;; 9 | ;;;start : integer or nil 10 | ;;; 11 | ;;;end : integer or nil 12 | ;;; 13 | ;;;from-end : atom (T or nil) 14 | ;;; 15 | ;;;return : sequence 16 | ;;; 17 | ;;; sequence is STR SYM LIST VARIANT(STR SAFEARRAY) SAFEARRAY 18 | 19 | ;;; +------------------------------------------------------+ 20 | ;;; Copyright (c) 2020 manual chair japan 21 | ;;; Released under the MIT license 22 | ;;; https://opensource.org/licenses/mit-license.php 23 | ;;; +------------------------------------------------------+ 24 | 25 | ;;;_$ (remove-repetition '(0 0 1 1 2 2 1 2) '= nil nil nil) 26 | ;;;(0 1 2 1 2) 27 | ;;;_$ (remove-repetition '(0 0 1 1 2 2 1 2) '= 1 5 nil) 28 | ;;;(0 0 1 2 2 1 2) 29 | ;;;_$ (remove-repetition "WwwwwwHOooooo" 'char-equal nil nil nil) 30 | ;;;"wHo" 31 | ;;;_$ (remove-repetition "WwwwwwHOooooo" 'char-equal nil nil T) 32 | ;;;"WHO" 33 | 34 | (include 'sequencep-list "./sequences/_sequencep-list") 35 | (include 'sequence-type-of "./sequences/_sequence-type-of") 36 | (include 'remove-repetition-list "./sequences/remove-repetition-list") 37 | 38 | (defun remove-repetition (sequence test-func start end from-end) 39 | (coerce (remove-repetition-list 40 | (sequencep-list sequence) 41 | test-func 42 | start 43 | end 44 | from-end 45 | ) 46 | (sequence-type-of sequence) 47 | ) 48 | ) 49 | -------------------------------------------------------------------------------- /sequences/remove.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'remove "./sequences/remove") 2 | 3 | ;;;(remove item sequence test-func start end count from-end) 4 | ;;; 5 | ;;;item : atom or list 6 | ;;; 7 | ;;;sequence : sequence 8 | ;;; 9 | ;;;test-func : function 10 | ;;; 11 | ;;;start : integer or nil 12 | ;;; 13 | ;;;end : integer or nil 14 | ;;; 15 | ;;;count : integer or nil 16 | ;;; 17 | ;;;from-end : atom (T or nil) 18 | ;;; 19 | ;;;return : sequence 20 | ;;; 21 | ;;; sequence is STR SYM LIST VARIANT(STR SAFEARRAY) SAFEARRAY 22 | 23 | ;;; +------------------------------------------------------+ 24 | ;;; Copyright (c) 2020 manual chair japan 25 | ;;; Released under the MIT license 26 | ;;; https://opensource.org/licenses/mit-license.php 27 | ;;; +------------------------------------------------------+ 28 | 29 | ;;;_$ (remove 'A '(a b c A B C a b) nil nil nil nil nil) 30 | ;;;(B C B C B) 31 | ;;;_$ (remove 'A '(a b c A B C a b) nil nil nil 2 nil) 32 | ;;;(B C B C A B) 33 | ;;;_$ (remove 'A '(a b c A B C a b) nil nil nil 2 T) 34 | ;;;(A B C B C B) 35 | ;;;_$ (remove 'A '(a b c A B C a b) nil nil 6 2 T) 36 | ;;;(B C B C A B) 37 | ;;;_$ (remove (ascii "A") "abcABCab" nil nil nil nil nil) 38 | ;;;"abcBCab" 39 | ;;;_$ (remove (ascii "A") "abcABCab" 'char-equal nil nil nil nil) 40 | ;;;"bcBCb" 41 | 42 | (include 'functionp "./flow/functionp") 43 | (include 'remove-if "./sequences/remove-if") 44 | 45 | (defun remove (item sequence test-func start end count from-end) 46 | (if (functionp (eval (setq test-func (default test-func ''equal)))) 47 | (remove-if 48 | (function (lambda (test-item) (apply test-func (list item test-item))) 49 | ) 50 | sequence 51 | start 52 | end 53 | count 54 | from-end 55 | ) 56 | (exit) 57 | ) 58 | ) 59 | -------------------------------------------------------------------------------- /sequences/replace-all-list.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'replace-all-list "./sequences/replace-all-list") 2 | 3 | ;;;(replace-all-list new-sub-list sub-list alist test-func start end) 4 | ;;; 5 | ;;;new-sub-list : list 6 | ;;; 7 | ;;;sub-list : list 8 | ;;; 9 | ;;;alist : list 10 | ;;; 11 | ;;;test-func : test function symbol (default equal) 12 | ;;; 13 | ;;;start : integer or nil 14 | ;;; 15 | ;;;end : integer or nil 16 | ;;; 17 | ;;;return : list 18 | 19 | ;;; +------------------------------------------------------+ 20 | ;;; Copyright (c) 2020 manual chair japan 21 | ;;; Released under the MIT license 22 | ;;; https://opensource.org/licenses/mit-license.php 23 | ;;; +------------------------------------------------------+ 24 | 25 | ;;;_$ (replace-all-list '(A B C) '(3 4) '(0 1 2 3 4 0 1 2 3 4) nil nil nil) 26 | ;;;(0 1 2 A B C 0 1 2 A B C) 27 | ;;;_$ (replace-all-list '(A B C) '(3 4) '(0 1 2 3 4 0 1 2 3 4) nil 5 nil) 28 | ;;;(0 1 2 3 4 0 1 2 A B C) 29 | 30 | (include 'default "./common/default") 31 | (include 'search-list "./sequences/search-list") 32 | (include 'subseq-list "./sequences/subseq-list") 33 | 34 | (defun replace-all-list:sub (alist / index) 35 | (if 36 | (not 37 | (null (setq index (search-list sub-list alist test-func nil nil nil)) 38 | ) 39 | ) 40 | (append (subseq-list alist 0 index) 41 | new-sub-list 42 | (replace-all-list:sub (subseq-list alist (+ index skip) nil)) 43 | ) 44 | alist 45 | ) 46 | ) 47 | 48 | (defun replace-all-list 49 | (new-sub-list sub-list alist test-func start end / skip) 50 | (setq skip (length sub-list) 51 | start (max 0 (default start '0)) 52 | end (min (default end '(length alist)) (length alist)) 53 | ) 54 | (append (subseq-list alist 0 start) 55 | (replace-all-list:sub (subseq-list alist start end)) 56 | (subseq-list alist end nil) 57 | ) 58 | ) -------------------------------------------------------------------------------- /sequences/replace-all.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'replace-all "./sequences/replace-all") 2 | 3 | ;;;(replace-all new-sub-sequence sub-sequence sequence start end) 4 | ;;; 5 | ;;;new-sub-sequence : sequence 6 | ;;; 7 | ;;;sub-sequence : sequence 8 | ;;; 9 | ;;;sequence : sequence 10 | ;;; 11 | ;;;test-func : test function symbol (default equal) 12 | ;;; 13 | ;;;start : integer or nil 14 | ;;; 15 | ;;;end : integer or nil 16 | ;;; 17 | ;;;return : sequence 18 | ;;; 19 | ;;; sequence is STR SYM LIST VARIANT(STR SAFEARRAY) SAFEARRAY 20 | 21 | ;;; +------------------------------------------------------+ 22 | ;;; Copyright (c) 2020 manual chair japan 23 | ;;; Released under the MIT license 24 | ;;; https://opensource.org/licenses/mit-license.php 25 | ;;; +------------------------------------------------------+ 26 | 27 | ;;;_$ (replace-all '(A B C) '(3 4) '(0 1 2 3 4 0 1 2 3 4) nil nil nil) 28 | ;;;(0 1 2 A B C 0 1 2 A B C) 29 | ;;;_$ (replace-all '(A B C) '(3 4) '(0 1 2 3 4 0 1 2 3 4) nil 5 nil) 30 | ;;;(0 1 2 3 4 0 1 2 A B C) 31 | ;;;_$ (replace-all "Pencil" "Pen" "Pen Apple Pinaple Pen" nil nil nil) 32 | ;;;"Pencil Apple Pinaple Pencil" 33 | ;;;_$ (replace-all "Pinapple" "APPLE" "Pen apple Apple APPLE" nil nil nil) 34 | ;;;"Pen apple Apple Pinapple" 35 | ;;;_$ (replace-all "Pinapple" "APPLE" "Pen apple Apple APPLE" 'char-equal nil nil) 36 | ;;;"Pen Pinapple Pinapple Pinapple" 37 | 38 | (include 'coerce "./types/coerce") 39 | (include 'sequencep-list "./sequences/_sequencep-list") 40 | (include 'sequence-type-of "./sequences/_sequence-type-of") 41 | (include 'replace-all-list "./sequences/replace-all-list") 42 | 43 | (defun replace-all 44 | (new-sub-sequence sub-sequence sequence test-func start end) 45 | (coerce (replace-all-list 46 | (sequencep-list new-sub-sequence) 47 | (sequencep-list sub-sequence) 48 | (sequencep-list sequence) 49 | test-func 50 | start 51 | end 52 | ) 53 | (sequence-type-of sequence) 54 | ) 55 | ) -------------------------------------------------------------------------------- /sequences/replacelis-all-list.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'replacelis-all-list "./sequences/replacelis-all-list") 2 | 3 | ;;;(replacelis-all-list assoc-list alist start end) 4 | ;;; 5 | ;;;assoc-list : association list 6 | ;;; 7 | ;;;alist : list 8 | ;;; 9 | ;;;test-func : test function symbol (default equal) 10 | ;;; 11 | ;;;start : integer or nil 12 | ;;; 13 | ;;;end : integer or nil 14 | ;;; 15 | ;;;return : list 16 | 17 | ;;; +------------------------------------------------------+ 18 | ;;; Copyright (c) 2020 manual chair japan 19 | ;;; Released under the MIT license 20 | ;;; https://opensource.org/licenses/mit-license.php 21 | ;;; +------------------------------------------------------+ 22 | 23 | ;;;_$ (replacelis-all-list '(((0 1) A) ((2 3 4) < >)) '(0 1 2 3 4 0 1 2 3 4) nil nil nil) 24 | ;;;(A 12 13 14 5 A 12 13 14 5) 25 | ;;;_$ (replacelis-all-list '(((0 1) A) ((2 3 4) 12 13 14)) '(0 1 2 3 4 5 0 1 2 3 4 5) nil 2 10) 26 | ;;;(0 1 12 13 14 5 A 2 3 4 5) 27 | 28 | (include 'default "./common/default") 29 | (include 'mapc "./conses/mapc") 30 | (include 'subseq-list "./sequences/subseq-list") 31 | (include 'replace-all-list "./sequences/replace-all-list") 32 | 33 | (defun replacelis-all-list:sub (alist) 34 | (mapc (function (lambda (cell) 35 | (setq alist (replace-all-list 36 | (cdr cell) 37 | (car cell) 38 | alist 39 | test-func 40 | nil 41 | nil 42 | ) 43 | ) 44 | ) 45 | ) 46 | (list assoc-list) 47 | ) 48 | alist 49 | ) 50 | 51 | (defun replacelis-all-list (assoc-list alist test-func start end) 52 | (setq start (max 0 (default start '0)) 53 | end (min (default end '(length alist)) (length alist)) 54 | ) 55 | (append (subseq-list alist 0 start) 56 | (replacelis-all-list:sub (subseq-list alist start end)) 57 | (subseq-list alist end nil) 58 | ) 59 | ) -------------------------------------------------------------------------------- /sequences/replacelis-all.LSP: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/manualChair/commonlib/79164a197831e89b76f86d452c55688ca0d896a6/sequences/replacelis-all.LSP -------------------------------------------------------------------------------- /sequences/reverse-sequence.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'reverse-sequence "./sequences/reverse-sequence") 2 | 3 | ;;;(reverse-sequence sequence) 4 | ;;; 5 | ;;;sequence : sequence 6 | ;;; 7 | ;;;return : sequence 8 | ;;; 9 | ;;; sequence is STR SYM LIST VARIANT(STR SAFEARRAY) SAFEARRAY 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | (include 'coerce "./types/coerce") 18 | (include 'sequencep-list "./sequences/_sequencep-list") 19 | (include 'sequence-type-of "./sequences/_sequence-type-of") 20 | 21 | (defun reverse-sequence (sequence) 22 | (coerce (reverse (sequencep-list sequence)) (sequence-type-of sequence)) 23 | ) -------------------------------------------------------------------------------- /sequences/search.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'search "./sequences/search") 2 | 3 | ;;;(search sub-sequence sequencestart start end from-end) 4 | ;;; 5 | ;;;sub-sequence : sequence 6 | ;;; 7 | ;;;sequence : sequence 8 | ;;; 9 | ;;;test-func : test function symbol (default equal) 10 | ;;; 11 | ;;;start : integer or nil 12 | ;;; 13 | ;;;end : integer or nil 14 | ;;; 15 | ;;;from-end : atom (T or nil) 16 | ;;; 17 | ;;;return : integer of index. zero-indexed. 18 | ;;; 19 | ;;; sequence is STR SYM LIST VARIANT(STR SAFEARRAY) SAFEARRAY 20 | 21 | ;;; +------------------------------------------------------+ 22 | ;;; Copyright (c) 2020 manual chair japan 23 | ;;; Released under the MIT license 24 | ;;; https://opensource.org/licenses/mit-license.php 25 | ;;; +------------------------------------------------------+ 26 | 27 | ;;;_$ (search "well" "All is well that ends well" nil nil nil nil) 28 | ;;;7 29 | ;;;_$ (search "�݂���" "����݂���̂����ɂ���݂���" nil nil nil nil) 30 | ;;;2 31 | ;;;_$ (search '(3 4) '(0 1 2 3 4 0 1 2 3 4) nil nil nil nil) 32 | ;;;3 33 | ;;;_$ (search '(3 4) '(0 1 2 3 4 0 1 2 3 4) nil nil nil T) 34 | ;;;8 35 | ;;;_$ (search '(3 4) '(0 1 2 3 4 0 1 2 3 4) nil 5 nil nil) 36 | ;;;8 37 | ;;;_$ (search '(3 4) '(0 1 2 3 4 0 1 2 3 4) nil nil 5 T) 38 | ;;;3 39 | ;;;_$ (search "APPLE" "Pen apple Apple APPLE" nil nil nil nil) 40 | ;;;16 41 | ;;;_$ (search "APPLE" "Pen apple Apple APPLE" 'char-equal nil nil nil) 42 | ;;;4 43 | 44 | (include 'sequencep-list "./sequences/_sequencep-list") 45 | (include 'search-list "./sequences/search-list") 46 | 47 | (defun search (sub-sequence sequence test-func start end from-end) 48 | (search-list 49 | (sequencep-list sub-sequence) 50 | (sequencep-list sequence) 51 | test-func 52 | start 53 | end 54 | from-end 55 | ) 56 | ) 57 | -------------------------------------------------------------------------------- /sequences/sequence-length.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'sequence-length "./sequences/sequence-length") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'sequence-list "./sequences/_sequence-list") 10 | 11 | (defun sequence-length (sequence) 12 | (length (sequence-list sequence)) 13 | ) -------------------------------------------------------------------------------- /sequences/subseq-list.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'subseq-list "./sequences/subseq-list") 2 | 3 | ;;;(subseq-list alist start end) 4 | ;;; subseq of only list version 5 | ;;; 6 | ;;;alist : list 7 | ;;; 8 | ;;;start : integer or nil 9 | ;;; 10 | ;;;end : integer or nil 11 | ;;; 12 | ;;;return : list 13 | ;;; sub-sequence of preseq that begin index start 14 | ;;; and end index (1- end). 15 | 16 | ;;; +------------------------------------------------------+ 17 | ;;; Copyright (c) 2020 manual chair japan 18 | ;;; Released under the MIT license 19 | ;;; https://opensource.org/licenses/mit-license.php 20 | ;;; +------------------------------------------------------+ 21 | 22 | ;;;_$ (subseq '(0 1 2 3 4 5 6) 1 4) 23 | ;;;(1 2 3) 24 | ;;;_$ (subseq '(0 1 2 3 4 5 6) 2 nil) 25 | ;;;(2 3 4 5 6) 26 | ;;;_$ (subseq '(0 1 2 3 4 5 6) nil 3) 27 | ;;;(0 1 2) 28 | ;;;_$ (subseq '(0 1 2 3 4 5 6) nil nil) 29 | ;;;(0 1 2 3 4 5 6) 30 | 31 | (include 'default "./common/default") 32 | (include 'integerp "./numbers/integerp") 33 | 34 | (defun subseq:sub (target counter) 35 | (if (< counter end) 36 | (if (<= start counter) 37 | (cons (car target) (subseq:sub (cdr target) (1+ counter))) 38 | (subseq:sub (cdr target) (1+ counter)) 39 | ) 40 | ) 41 | ) 42 | 43 | (defun subseq-list (alist start end) 44 | (setq start (max 0 (default start '0)) 45 | end (min (default end '(length alist)) (length alist)) 46 | ) 47 | (if (and (integerp start) (integerp end)) 48 | (subseq:sub alist 0) 49 | (exit) 50 | ) 51 | ) 52 | 53 | 54 | -------------------------------------------------------------------------------- /sequences/subseq.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'subseq "./sequences/subseq") 2 | 3 | ;;;(subseq sequence start end) 4 | ;;; 5 | ;;;sequence : sequence 6 | ;;; 7 | ;;;start : integer or nil 8 | ;;; 9 | ;;;end : integer or nil 10 | ;;; 11 | ;;;return : sequence 12 | ;;; 13 | ;;; sequence is STR SYM LIST VARIANT(STR SAFEARRAY) SAFEARRAY 14 | 15 | ;;; +------------------------------------------------------+ 16 | ;;; Copyright (c) 2020 manual chair japan 17 | ;;; Released under the MIT license 18 | ;;; https://opensource.org/licenses/mit-license.php 19 | ;;; +------------------------------------------------------+ 20 | 21 | ;;;_$ (subseq '(0 1 2 3 4 5 6) 1 4) 22 | ;;;(1 2 3) 23 | ;;;_$ (subseq '(0 1 2 3 4 5 6) 2 nil) 24 | ;;;(2 3 4 5 6) 25 | ;;;_$ (subseq '(0 1 2 3 4 5 6) nil 3) 26 | ;;;(0 1 2) 27 | ;;;_$ (subseq '(0 1 2 3 4 5 6) nil nil) 28 | ;;;(0 1 2 3 4 5 6) 29 | ;;;_$ (subseq "0123456" 2 4) 30 | ;;;"23" 31 | 32 | (include 'coerce "./types/coerce") 33 | (include 'sequencep-list "./sequences/_sequencep-list") 34 | (include 'sequence-type-of "./sequences/_sequence-type-of") 35 | (include 'subseq-list "./sequences/subseq-list") 36 | 37 | (defun subseq (sequence start end) 38 | (coerce (subseq-list (sequencep-list sequence) start end) 39 | (sequence-type-of sequence) 40 | ) 41 | ) -------------------------------------------------------------------------------- /sequences/substitute--if.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'substitute-if "./sequences/substitute-if") 2 | 3 | ;;;(substitute-if new-item predicate sequence start end count from-end) 4 | ;;; 5 | ;;;new-item : atom or list 6 | ;;; 7 | ;;;predicate : predicate function 8 | ;;; function apply single argment. 9 | ;;; 10 | ;;;sequence : sequence 11 | ;;; 12 | ;;;start : integer or nil 13 | ;;; 14 | ;;;end : integer or nil 15 | ;;; 16 | ;;;count : integer or nil 17 | ;;; 18 | ;;;from-end : atom (T or nil) 19 | ;;; 20 | ;;;return : sequence 21 | ;;; 22 | ;;; sequence is STR SYM LIST VARIANT(STR SAFEARRAY) SAFEARRAY 23 | 24 | ;;; +------------------------------------------------------+ 25 | ;;; Copyright (c) 2020 manual chair japan 26 | ;;; Released under the MIT license 27 | ;;; https://opensource.org/licenses/mit-license.php 28 | ;;; +------------------------------------------------------+ 29 | 30 | ;;;_$ (substitute-if 1 (function (lambda (item) (equal item 'A))) '(a b c A B C a b) nil nil nil nil) 31 | ;;;(1 B C 1 B C 1 B) 32 | ;;;_$ (substitute-if 1 (function (lambda (item) (equal item 'A))) '(a b c A B C a b) nil nil 2 nil) 33 | ;;;(1 B C 1 B C A B) 34 | ;;;_$ (substitute-if 1 (function (lambda (item) (equal item 'A))) '(a b c A B C a b) nil nil 2 T) 35 | ;;;(A B C 1 B C 1 B) 36 | ;;;_$ (substitute-if 1 (function (lambda (item) (equal item 'A))) '(a b c A B C a b) nil 6 2 T) 37 | ;;;(1 B C 1 B C A B) 38 | ;;;_$ (substitute-if (ascii "1") (function (lambda (item) (equal item (ascii "a")))) "abcABCabc" nil nil nil nil) 39 | ;;;"1bcABC1bc" 40 | 41 | (include 'coerce "./types/coerce") 42 | (include 'sequencep-list "./sequences/_sequencep-list") 43 | (include 'sequence-type-of "./sequences/_sequence-type-of") 44 | (include 'substitute-list-if 45 | "./sequences/substitute-list-if" 46 | ) 47 | 48 | (defun substitute-if ($_new-item $_predicate $_sequence 49 | $_start $_end $_count 50 | $_from-end 51 | ) 52 | (coerce (substitute-list-if 53 | $_new-item 54 | $_predicate 55 | (sequencep-list $_sequence) 56 | $_start 57 | $_end 58 | $_count 59 | $_from-end 60 | ) 61 | (sequence-type-of $_sequence) 62 | ) 63 | ) 64 | -------------------------------------------------------------------------------- /sequences/substitute.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'substitute "./sequences/substitute") 2 | 3 | ;;;(substitute newitem olditem sequence test-func start end count from-end) 4 | ;;; 5 | ;;;newitem : atom or list 6 | ;;; 7 | ;;;olditem : atom or list 8 | ;;; 9 | ;;;sequence : sequence 10 | ;;; 11 | ;;;test-func : function 12 | ;;; 13 | ;;;start : integer or nil 14 | ;;; 15 | ;;;end : integer or nil 16 | ;;; 17 | ;;;count : integer or nil 18 | ;;; 19 | ;;;from-end : atom (T or nil) 20 | ;;; 21 | ;;;return : sequence 22 | ;;; 23 | ;;; sequence is STR SYM LIST VARIANT(STR SAFEARRAY) SAFEARRAY 24 | 25 | ;;; +------------------------------------------------------+ 26 | ;;; Copyright (c) 2020 manual chair japan 27 | ;;; Released under the MIT license 28 | ;;; https://opensource.org/licenses/mit-license.php 29 | ;;; +------------------------------------------------------+ 30 | 31 | ;;;_$ (substitute 1 'A '(a b c A B C a b) nil nil nil nil nil) 32 | ;;;(1 B C 1 B C 1 B) 33 | ;;;_$ (substitute 1 'A '(a b c A B C a b) nil nil nil 2 nil) 34 | ;;;(1 B C 1 B C A B) 35 | ;;;_$ (substitute 1 'A '(a b c A B C a b) nil nil nil 2 T) 36 | ;;;(A B C 1 B C 1 B) 37 | ;;;_$ (substitute 1 'A '(a b c A B C a b) nil nil 6 2 T) 38 | ;;;(1 B C 1 B C A B) 39 | ;;;_$ (substitute (ascii "H") (ascii "h") "hello, hey, hi!" nil nil nil nil nil) 40 | ;;;"Hello, Hey, Hi!" 41 | ;;;_$ (substitute (ascii "H") (ascii "h") "hello, hey, hi!" nil nil nil 2 T) 42 | ;;;"hello, Hey, Hi!" 43 | 44 | (include 'functionp "./flow/functionp") 45 | (include 'substitute-if "./sequences/substitute--if") 46 | 47 | (defun substitute 48 | (newitem olditem sequence test-func start end count from-end) 49 | (if (functionp (eval (setq test-func (default test-func ''equal)))) 50 | (substitute-if 51 | newitem 52 | (function 53 | (lambda (test-item) (apply test-func (list olditem test-item))) 54 | ) 55 | sequence 56 | start 57 | end 58 | count 59 | from-end 60 | ) 61 | (exit) 62 | ) 63 | ) -------------------------------------------------------------------------------- /sequences/thin-out-list.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'thin-out-list "./sequences/thin-out-list") 2 | 3 | ;;;(thin-out-list alist start end) 4 | ;;; 5 | ;;;alist : list 6 | ;;; 7 | ;;;start end : integer or nil 8 | ;;; 9 | ;;;return : list 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | ;;;_$ (thin-out-list '(0 1 2 3 4 5 6 7 8 9) 5 6) 18 | ;;;(0 1 2 3 4 6 7 8 9) 19 | ;;;_$ (thin-out-list '(0 1 2 3 4 5 6 7 8 9) nil nil) 20 | ;;;nil 21 | ;;;_$ (thin-out-list '(0 1 2 3 4 5 6 7 8 9) 3 nil) 22 | ;;;(0 1 2) 23 | ;;;_$ (thin-out-list '(0 1 2 3 4 5 6 7 8 9) nil 6) 24 | ;;;(6 7 8 9) 25 | 26 | (include 'remove-list-if "./sequences/remove-list-if") 27 | 28 | (defun thin-out-list (alist start end) 29 | (remove-list-if (function (lambda (item) T)) alist start end nil nil) 30 | ) 31 | -------------------------------------------------------------------------------- /sequences/thin-out.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'thin-out "./sequences/thin-out") 2 | 3 | ;;;(thin-out sequence start end) 4 | ;;; 5 | ;;;sequence : sequence 6 | ;;; 7 | ;;;start end : integer or nil 8 | ;;; 9 | ;;;return : sequence 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | ;;;_$ (thin-out "0123456789" 5 6) 18 | ;;;"012346789" 19 | ;;;_$ (thin-out "0123456789" nil nil) 20 | ;;;"" 21 | ;;;_$ (thin-out "0123456789" 3 nil) 22 | ;;;"012" 23 | ;;;_$ (thin-out "0123456789" nil 6) 24 | ;;;"6789" 25 | ;;;_$ (thin-out '(0 1 2 3 4 5 6 7 8 9) 5 6) 26 | ;;;(0 1 2 3 4 6 7 8 9) 27 | 28 | (include 'remove-if "./sequences/remove-if") 29 | 30 | (defun thin-out (sequence start end) 31 | (remove-if (function (lambda (item) T)) sequence start end nil nil) 32 | ) 33 | -------------------------------------------------------------------------------- /streams/with-open-file.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'with-open-file "./streams/with-open-file") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'typep "./types/typep") 10 | (include 'compose "./evaluation/compose") 11 | 12 | (defun with-open-file ($_filename $_mode $_func $_args) 13 | (if (and $_filename (typep $_filename 'STR) $_mode (typep $_mode 'STR)) 14 | ((lambda (*error* / $stream $_result) 15 | (setq $stream (open $_filename $_mode) 16 | $_result (apply $_func $_args) 17 | ) 18 | (close $stream) 19 | $_result 20 | ) 21 | (compose (function (lambda ($_msg) (close $stream) $_msg)) '*error*) 22 | ) 23 | (exit) 24 | ) 25 | ) -------------------------------------------------------------------------------- /streams/write-string.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'write-string "./streams/write-string") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'default "./common/default") 10 | (include 'typep "./types/typep") 11 | (include 'coerce "./types/coerce") 12 | (include 'mapc "./conses/mapc") 13 | (include 'stringp "./strings/stringp") 14 | (include 'sequence-type-of "./sequences/_sequence-type-of") 15 | (include 'subseq-list "./sequences/subseq-list") 16 | 17 | (defun write-string (astring stream start end / alist) 18 | (if (stringp astring) 19 | (progn 20 | (setq alist (subseq-list (coerce astring 'SLIST) start end) 21 | start (max 0 (default start '0)) 22 | end (min (default end '(length alist)) (length alist)) 23 | ) 24 | (if (typep stream 'FILE) 25 | (mapc 26 | (function (lambda (ascii-code) (write-char ascii-code stream))) 27 | (list (coerce alist 'LIST)) 28 | ) 29 | (prompt (coerce alist 'STR)) 30 | ) 31 | (coerce alist (sequence-type-of astring)) 32 | ) 33 | ) 34 | ) -------------------------------------------------------------------------------- /strings/_string-trim.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'string-trim:sub "./strings/_string-trim") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (defun string-trim:sub (clist) 10 | (if clist 11 | (if (member (car clist) trim-chars) 12 | (string-trim:sub (cdr clist)) 13 | clist 14 | ) 15 | ) 16 | ) 17 | -------------------------------------------------------------------------------- /strings/_stringp-list.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'stringp-list "./strings/_stringp-list") 2 | 3 | ;;;(stringp-list item) 4 | ;;; 5 | ;;;item : string, list, symbol, variant(string or safe-array), safe-array(integer) 6 | ;;; 7 | ;;;return : list meaning string 8 | 9 | ;;; +------------------------------------------------------+ 10 | ;;; Copyright (c) 2020 manual chair japan 11 | ;;; Released under the MIT license 12 | ;;; https://opensource.org/licenses/mit-license.php 13 | ;;; +------------------------------------------------------+ 14 | 15 | (include 'coerce "./types/coerce") 16 | (include 'stringp "./strings/stringp") 17 | 18 | (defun stringp-list (item) 19 | (if (stringp item) 20 | (if (not (null item)) 21 | (coerce item 'SLIST) 22 | ) 23 | (exit) 24 | ) 25 | ) -------------------------------------------------------------------------------- /strings/_to-variantp-string.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'to-variantp-string "./strings/_to-variantp-string") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'coerce "./types/coerce") 10 | 11 | (defun to-variantp-string (atype alist) 12 | (if (= atype 'VARIANT) 13 | (coerce alist 'STR) 14 | alist 15 | ) 16 | ) -------------------------------------------------------------------------------- /strings/char.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'char "./strings/char") 2 | 3 | ;;;(char astring n) 4 | ;;; 5 | ;;;astring : string, list, symbol, variant(string or safe-array), safe-array(integer) 6 | ;;; 7 | ;;;n : integer 8 | ;;; 9 | ;;;return : The nth character of string. Zero-indexed. 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | (include 'stringp-list "./strings/_stringp-list") 18 | 19 | (defun char:sub (alist) 20 | (if (and (not (minusp n)) (< n (length alist))) 21 | (nth n alist) 22 | (exit) 23 | ) 24 | ) 25 | 26 | (defun char (astring n) (char:sub (stringp-list astring))) -------------------------------------------------------------------------------- /strings/make-string.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'make-string "./strings/make-string") 2 | 3 | ;;;(make-string size initial-element) 4 | ;;; 5 | ;;;size : integer 6 | ;;; 7 | ;;;initial-element : integer,list 8 | ;;; 9 | ;;;return : string 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | ;;;_$ (make-string 5 (ascii "a")) 18 | ;;;"aaaaa" 19 | ;;;_$ (make-string 5 '(SHIFT_JIS 33440)) 20 | ;;;"����������" 21 | 22 | (include 'characterp "./characters/characterp") 23 | (include 'make-list "./conses/make-list") 24 | (include 'list->string "./types/multibyte/list-string") 25 | 26 | (defun make-string (size initial-element) 27 | (if (characterp initial-element) 28 | (list->string (make-list size initial-element)) 29 | (exit) 30 | ) 31 | ) -------------------------------------------------------------------------------- /strings/string-downcase.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'string-downcase "./strings/string-downcase") 2 | 3 | ;;;(string-downcase atype astring start end) 4 | ;;; 5 | ;;;atype : symbol ('STR 'SLIST 'SYM or 'VARIANT 'SAFEARRAY 'VECTOR) 6 | ;;; 7 | ;;;astring : string, list, symbol, variant(string or safe-array), safe-array(integer) 8 | ;;; 9 | ;;;start : integer or nil 10 | ;;; 11 | ;;;end : integer or nil 12 | ;;; 13 | ;;;return : string or list etc. 14 | 15 | ;;; +------------------------------------------------------+ 16 | ;;; Copyright (c) 2020 manual chair japan 17 | ;;; Released under the MIT license 18 | ;;; https://opensource.org/licenses/mit-license.php 19 | ;;; +------------------------------------------------------+ 20 | 21 | ;;;_$ (string-downcase 'STR "HEY! YOU ARE COOL." nil nil) 22 | ;;;"hey! you are cool." 23 | ;;;_$ (string-downcase 'STR "HEY! YOU ARE COOL." 6 nil) 24 | ;;;"HEY! You are cool." 25 | ;;;_$ (string-downcase 'STR "HEY! YOU ARE COOL." 6 10) 26 | ;;;"HEY! You aRE COOL." 27 | ;;;_$ (string-downcase 'SLIST "HEY! YOU ARE COOL." nil nil) 28 | ;;;(104 101 121 33 32 121 111 117 32 97 114 101 32 99 111 111 108 46) 29 | ;;;_$ (string-downcase 'VARIANT "HEY! YOU ARE COOL." nil nil) 30 | ;;;# 31 | ;;;_$ (string-downcase 'SAFEARRAY "HEY! YOU ARE COOL." nil nil) 32 | ;;;# 33 | 34 | (include 'default "./common/default") 35 | (include 'member-of-option-p "./common/member-of-option-p") 36 | (include 'coerce "./types/coerce") 37 | (include 'char-downcase "./characters/char-downcase") 38 | (include 'stringp-list "./strings/_stringp-list") 39 | (include 'to-variantp-string "./strings/_to-variantp-string") 40 | (include 'subseq-list "./sequences/subseq-list") 41 | 42 | (defun string-downcase (atype astring start end / sequence) 43 | (if (member-of-option-p 44 | 'string-downcase 45 | 'atype 46 | '(STR SLIST SYM VARIANT SAFEARRAY VECTOR) 47 | ) 48 | (progn 49 | (setq sequence (stringp-list astring) 50 | start (max 0 (default start '0)) 51 | end (min (default end '(length sequence)) (length sequence)) 52 | ) 53 | (coerce 54 | (to-variantp-string 55 | atype 56 | (append (subseq-list sequence 0 start) 57 | (mapcar 'char-downcase (subseq-list sequence start end)) 58 | (subseq-list sequence end nil) 59 | ) 60 | ) 61 | atype 62 | ) 63 | ) 64 | (exit) 65 | ) 66 | ) -------------------------------------------------------------------------------- /strings/string-equal.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'string-equal "./strings/string-equal") 2 | 3 | ;;;(string-equal string1 string2 start1 end1 start2 end2) 4 | ;;; 5 | ;;;string1 : string, list, symbol, variant(string or safe-array), safe-array(integer) 6 | ;;; 7 | ;;;string2 : string, list, symbol, variant(string or safe-array), safe-array(integer) 8 | ;;; 9 | ;;;start1 end1 start2 end2 : integer 10 | ;;; 11 | ;;;return : T or nil (ignore case) 12 | 13 | ;;; +------------------------------------------------------+ 14 | ;;; Copyright (c) 2020 manual chair japan 15 | ;;; Released under the MIT license 16 | ;;; https://opensource.org/licenses/mit-license.php 17 | ;;; +------------------------------------------------------+ 18 | 19 | ;;;_$ (string-equal "abc" "ABC" nil nil nil nil) 20 | ;;;T 21 | ;;;_$ (string-equal "������" "������" nil nil nil nil) ;_multi-byte-charactor 22 | ;;;T 23 | 24 | (include 'char-equal "./characters/char-equal") 25 | (include 'stringp-list "./strings/_stringp-list") 26 | (include 'subseq-list "./sequences/subseq-list") 27 | 28 | (defun string-equal:sub (clist1 clist2) 29 | (cond ((and clist1 clist2) 30 | (if (char-equal (car clist1) (car clist2)) 31 | (string-equal:sub (cdr clist1) (cdr clist2)) 32 | ) 33 | ) 34 | ((and clist1 (null clist2)) nil) 35 | ((and (null clist1) clist2) nil) 36 | ((and (null clist1) (null clist2)) T) 37 | ) 38 | ) 39 | 40 | (defun string-equal (string1 string2 start1 end1 start2 end2) 41 | (string-equal:sub 42 | (subseq-list (stringp-list string1) start1 end1) 43 | (subseq-list (stringp-list string2) start2 end2) 44 | ) 45 | ) -------------------------------------------------------------------------------- /strings/string-greaterp.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'string-greaterp "./strings/string-greaterp") ;_ > 2 | 3 | ;;;(string-greaterp string1 string2 start1 end1 start2 end2) 4 | ;;; 5 | ;;;string1 : string, list, symbol, variant(string or safe-array), safe-array(integer) 6 | ;;; 7 | ;;;string2 : string, list, symbol, variant(string or safe-array), safe-array(integer) 8 | ;;; 9 | ;;;start1 end1 start2 end2 : integer 10 | ;;; 11 | ;;;return : T or nil (ignore case) 12 | 13 | ;;; +------------------------------------------------------+ 14 | ;;; Copyright (c) 2020 manual chair japan 15 | ;;; Released under the MIT license 16 | ;;; https://opensource.org/licenses/mit-license.php 17 | ;;; +------------------------------------------------------+ 18 | 19 | ;;;_$ (string-greaterp "abc0" "ABC1" nil nil nil nil) 20 | ;;;nil 21 | ;;;_$ (string-greaterp "abc1" "ABC1" nil nil nil nil) 22 | ;;;nil 23 | ;;;_$ (string-greaterp "abc2" "ABC1" nil nil nil nil) 24 | ;;;T 25 | ;;;_$ (string-greaterp "ABC1-1" "ABC1" nil nil nil nil) 26 | ;;;T 27 | 28 | (include 'char-equal "./characters/char-equal") 29 | (include 'char-greaterp "./characters/char-greaterp") ;_ > 30 | (include 'stringp-list "./strings/_stringp-list") 31 | (include 'subseq-list "./sequences/subseq-list") 32 | 33 | (defun string-greaterp:sub (clist1 clist2) 34 | (cond ((and clist1 clist2) 35 | (if (char-equal (car clist1) (car clist2)) 36 | (string-greaterp:sub (cdr clist1) (cdr clist2)) 37 | (char-greaterp (car clist1) (car clist2)) 38 | ) 39 | ) 40 | ((and clist1 (null clist2)) T) 41 | ((and (null clist1) clist2) nil) 42 | ((and (null clist1) (null clist2)) nil) 43 | ) 44 | ) 45 | 46 | (defun string-greaterp 47 | (string1 string2 start1 end1 start2 end2) 48 | (string-greaterp:sub 49 | (subseq-list (stringp-list string1) start1 end1) 50 | (subseq-list (stringp-list string2) start2 end2) 51 | ) 52 | ) -------------------------------------------------------------------------------- /strings/string-left-trim.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'string-left-trim "./strings/string-left-trim") 2 | 3 | ;;;(string-left-trim atype char-bag astring) 4 | ;;; 5 | ;;;atype : symbol ('STR 'SLIST 'SYM or 'VARIANT 'SAFEARRAY 'VECTOR) 6 | ;;; 7 | ;;;char-bag : string, list, symbol, variant(string or safe-array), safe-array(integer) 8 | ;;; 9 | ;;;astring : string, list, symbol, variant(string or safe-array), safe-array(integer) 10 | ;;; 11 | ;;;return : string or list etc. 12 | 13 | ;;; +------------------------------------------------------+ 14 | ;;; Copyright (c) 2020 manual chair japan 15 | ;;; Released under the MIT license 16 | ;;; https://opensource.org/licenses/mit-license.php 17 | ;;; +------------------------------------------------------+ 18 | 19 | ;;;_$ (string-left-trim 'STR " ." " . . . HELLO . . .") 20 | ;;;"HELLO . . ." 21 | ;;;_$ (string-left-trim 'LIST " ." " . . . HELLO . . .") 22 | ;;;(72 69 76 76 79 32 46 32 46 32 46) 23 | ;;;_$ (string-left-trim 'VARIANT " ." " . . . HELLO . . .") 24 | ;;;# 25 | ;;;_$ (string-left-trim 'SAFEARRAY " ." " . . . HELLO . . .") 26 | ;;;# 27 | 28 | (include 'member-of-option-p "./common/member-of-option-p") 29 | (include 'coerce "./types/coerce") 30 | (include 'stringp-list "./strings/_stringp-list") 31 | (include 'to-variantp-string "./strings/_to-variantp-string") 32 | (include 'string-trim:sub "./strings/_string-trim") 33 | 34 | (defun string-left-trim (atype char-bag astring / sequence trim-chars) 35 | (if (member-of-option-p 36 | 'string-left-trim 37 | 'atype 38 | '(STR SLIST SYM VARIANT SAFEARRAY VECTOR) 39 | ) 40 | (progn 41 | (setq sequence (stringp-list astring) 42 | trim-chars (stringp-list char-bag) 43 | ) 44 | (coerce (to-variantp-string atype (string-trim:sub sequence)) atype) 45 | ) 46 | (exit) 47 | ) 48 | ) -------------------------------------------------------------------------------- /strings/string-length.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'string-length "./strings/string-length") 2 | 3 | ;;;(string-length astring) 4 | ;;; 5 | ;;;astring : string, symbol 6 | ;;; 7 | ;;;return : integer 8 | 9 | ;;; +------------------------------------------------------+ 10 | ;;; Copyright (c) 2020 manual chair japan 11 | ;;; Released under the MIT license 12 | ;;; https://opensource.org/licenses/mit-license.php 13 | ;;; +------------------------------------------------------+ 14 | 15 | ;;;_$ (string-length "01234") 16 | ;;;5 17 | ;;;_$ (string-length 'ABCDE) 18 | ;;;5 19 | 20 | (include 'stringp-list "./strings/_stringp-list") 21 | 22 | (defun string-length (astring) 23 | (length (stringp-list astring)) 24 | ) -------------------------------------------------------------------------------- /strings/string-lessp.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'string-lessp "./strings/string-lessp") ;_ < 2 | 3 | ;;;(string-lessp string1 string2 start1 end1 start2 end2) 4 | ;;; 5 | ;;;string1 : string, list, symbol, variant(string or safe-array), safe-array(integer) 6 | ;;; 7 | ;;;string2 : string, list, symbol, variant(string or safe-array), safe-array(integer) 8 | ;;; 9 | ;;;start1 end1 start2 end2 : integer 10 | ;;; 11 | ;;;return : T or nil (ignore case) 12 | 13 | ;;; +------------------------------------------------------+ 14 | ;;; Copyright (c) 2020 manual chair japan 15 | ;;; Released under the MIT license 16 | ;;; https://opensource.org/licenses/mit-license.php 17 | ;;; +------------------------------------------------------+ 18 | 19 | ;;;_$ (string-greaterp "abc0" "ABC1" nil nil nil nil) 20 | ;;;nil 21 | ;;;_$ (string-lessp "abc0" "ABC1" nil nil nil nil) 22 | ;;;T 23 | ;;;_$ (string-lessp "abc1" "ABC1" nil nil nil nil) 24 | ;;;nil 25 | ;;;_$ (string-lessp "abc2" "ABC1" nil nil nil nil) 26 | ;;;nil 27 | ;;;_$ (string-lessp "ABC1" "ABC1-1" nil nil nil nil) 28 | ;;;T 29 | 30 | (include 'char-equal "./characters/char-equal") 31 | (include 'char-lessp "./characters/char-lessp") ;_ < 32 | (include 'stringp-list "./strings/_stringp-list") 33 | (include 'subseq-list "./sequences/subseq-list") 34 | 35 | (defun string-lessp:sub (clist1 clist2) 36 | (cond ((and clist1 clist2) 37 | (if (char-equal (car clist1) (car clist2)) 38 | (string-lessp:sub (cdr clist1) (cdr clist2)) 39 | (char-lessp (car clist1) (car clist2)) 40 | ) 41 | ) 42 | ((and clist1 (null clist2)) nil) 43 | ((and (null clist1) clist2) T) 44 | ((and (null clist1) (null clist2)) nil) 45 | ) 46 | ) 47 | 48 | (defun string-lessp (string1 string2 start1 end1 start2 end2) 49 | (string-lessp:sub 50 | (subseq-list (stringp-list string1) start1 end1) 51 | (subseq-list (stringp-list string2) start2 end2) 52 | ) 53 | ) -------------------------------------------------------------------------------- /strings/string-not-equal.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'string-not-equal "./strings/string-not-equal") 2 | 3 | ;;;(string-not-equal string1 string2 start1 end1 start2 end2) 4 | ;;; 5 | ;;;string1 : string, list, symbol, variant(string or safe-array), safe-array(integer) 6 | ;;; 7 | ;;;string2 : string, list, symbol, variant(string or safe-array), safe-array(integer) 8 | ;;; 9 | ;;;start1 end1 start2 end2 : integer 10 | ;;; 11 | ;;;return : T or nil (ignore case) 12 | 13 | ;;; +------------------------------------------------------+ 14 | ;;; Copyright (c) 2020 manual chair japan 15 | ;;; Released under the MIT license 16 | ;;; https://opensource.org/licenses/mit-license.php 17 | ;;; +------------------------------------------------------+ 18 | 19 | ;;;_$ (string-not-equal "abc" "ABC" nil nil nil nil) 20 | ;;;nil 21 | ;;;_$ (string-not-equal "������" "������" nil nil nil nil) 22 | ;;;nil 23 | 24 | (include 'string-equal "./strings/string-equal") 25 | 26 | (defun string-not-equal (string1 string2 start1 end1 start2 end2) 27 | (not (string-equal string1 string2 start1 end1 start2 end2)) 28 | ) -------------------------------------------------------------------------------- /strings/string-not-greaterp.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'string-not-greaterp "./strings/string-not-greaterp") ;_ <= 2 | 3 | ;;;(string-not-greaterp string1 string2 start1 end1 start2 end2) 4 | ;;; 5 | ;;;string1 : string, list, symbol, variant(string or safe-array), safe-array(integer) 6 | ;;; 7 | ;;;string2 : string, list, symbol, variant(string or safe-array), safe-array(integer) 8 | ;;; 9 | ;;;start1 end1 start2 end2 : integer 10 | ;;; 11 | ;;;return : T or nil (ignore case) 12 | 13 | ;;; +------------------------------------------------------+ 14 | ;;; Copyright (c) 2020 manual chair japan 15 | ;;; Released under the MIT license 16 | ;;; https://opensource.org/licenses/mit-license.php 17 | ;;; +------------------------------------------------------+ 18 | 19 | ;;;_$ (string-not-greaterp "abc0" "ABC1" nil nil nil nil) 20 | ;;;T 21 | ;;;_$ (string-not-greaterp "abc1" "ABC1" nil nil nil nil) 22 | ;;;T 23 | ;;;_$ (string-not-greaterp "abc2" "ABC1" nil nil nil nil) 24 | ;;;nil 25 | ;;;_$ (string-not-greaterp "abc1" "ABC1-1" nil nil nil nil) 26 | ;;;T 27 | 28 | (include 'string-greaterp "./strings/string-greaterp") ;_ > 29 | 30 | (defun string-not-greaterp (string1 string2 start1 end1 start2 end2) 31 | (not (string-greaterp string1 string2 start1 end1 start2 end2)) 32 | ) -------------------------------------------------------------------------------- /strings/string-not-lessp.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'string-not-lessp "./strings/string-not-lessp") ;_ >= 2 | 3 | ;;;(string-not-lessp string1 string2 start1 end1 start2 end2) 4 | ;;; 5 | ;;;string1 : string, list, symbol, variant(string or safe-array), safe-array(integer) 6 | ;;; 7 | ;;;string2 : string, list, symbol, variant(string or safe-array), safe-array(integer) 8 | ;;; 9 | ;;;start1 end1 start2 end2 : integer 10 | ;;; 11 | ;;;return : T or nil (ignore case) 12 | 13 | ;;; +------------------------------------------------------+ 14 | ;;; Copyright (c) 2020 manual chair japan 15 | ;;; Released under the MIT license 16 | ;;; https://opensource.org/licenses/mit-license.php 17 | ;;; +------------------------------------------------------+ 18 | 19 | ;;;_$ (string-not-lessp "abc0" "ABC1" nil nil nil nil) 20 | ;;;nil 21 | ;;;_$ (string-not-lessp "abc1" "ABC1" nil nil nil nil) 22 | ;;;T 23 | ;;;_$ (string-not-lessp "abc2" "ABC1" nil nil nil nil) 24 | ;;;T 25 | ;;;_$ (string-not-lessp "abc1-1" "ABC1" nil nil nil nil) 26 | ;;;T 27 | 28 | (include 'string-lessp "./strings/string-lessp") ;_ < 29 | 30 | (defun string-not-lessp (string1 string2 start1 end1 start2 end2) 31 | (not (string-lessp string1 string2 start1 end1 start2 end2)) 32 | ) -------------------------------------------------------------------------------- /strings/string-right-trim.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'string-right-trim "./strings/string-right-trim") 2 | 3 | ;;;(string-right-trim atype char-bag astring) 4 | ;;; 5 | ;;;atype : symbol ('STR 'SLIST 'SYM or 'VARIANT 'SAFEARRAY 'VECTOR) 6 | ;;; 7 | ;;;char-bag : string, list, symbol, variant(string or safe-array), safe-array(integer) 8 | ;;; 9 | ;;;astring : string, list, symbol, variant(string or safe-array), safe-array(integer) 10 | ;;; 11 | ;;;return : string or list etc. 12 | 13 | ;;; +------------------------------------------------------+ 14 | ;;; Copyright (c) 2020 manual chair japan 15 | ;;; Released under the MIT license 16 | ;;; https://opensource.org/licenses/mit-license.php 17 | ;;; +------------------------------------------------------+ 18 | 19 | ;;;_$ (string-right-trim 'STR " ." " . . . HELLO . . .") 20 | ;;;" . . . HELLO" 21 | ;;;_$ (string-right-trim 'LIST " ." " . . . HELLO . . .") 22 | ;;;(32 46 32 46 32 46 32 72 69 76 76 79) 23 | ;;;_$ (string-right-trim 'VARIANT " ." " . . . HELLO . . .") 24 | ;;;# 25 | ;;;_$ (string-right-trim 'SAFEARRAY " ." " . . . HELLO . . .") 26 | ;;;# 27 | 28 | (include 'member-of-option-p "./common/member-of-option-p") 29 | (include 'coerce "./types/coerce") 30 | (include 'stringp-list "./strings/_stringp-list") 31 | (include 'to-variantp-string "./strings/_to-variantp-string") 32 | (include 'string-trim:sub "./strings/_string-trim") 33 | 34 | (defun string-right-trim (atype char-bag astring / sequence trim-chars) 35 | (if (member-of-option-p 36 | 'string-right-trim 37 | 'atype 38 | '(STR SLIST SYM VARIANT SAFEARRAY VECTOR) 39 | ) 40 | (progn (setq sequence (reverse (stringp-list astring)) 41 | trim-chars (stringp-list char-bag) 42 | ) 43 | (coerce 44 | (to-variantp-string atype (reverse (string-trim:sub sequence))) 45 | atype 46 | ) 47 | ) 48 | (exit) 49 | ) 50 | ) -------------------------------------------------------------------------------- /strings/string-trim.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'string-trim "./strings/string-trim") 2 | 3 | ;;;(string-trim atype char-bag astring) 4 | ;;; 5 | ;;;atype : symbol ('STR 'SLIST 'SYM or 'VARIANT 'SAFEARRAY 'VECTOR) 6 | ;;; 7 | ;;;char-bag : string, list, symbol, variant(string or safe-array), safe-array(integer) 8 | ;;; 9 | ;;;astring : string, list, symbol, variant(string or safe-array), safe-array(integer) 10 | ;;; 11 | ;;;return : string or list etc. 12 | 13 | ;;; +------------------------------------------------------+ 14 | ;;; Copyright (c) 2020 manual chair japan 15 | ;;; Released under the MIT license 16 | ;;; https://opensource.org/licenses/mit-license.php 17 | ;;; +------------------------------------------------------+ 18 | 19 | ;;;_$ (string-trim 'STR " ." " . . . HELLO . . .") 20 | ;;;"HELLO" 21 | ;;;_$ (string-trim 'LIST " ." " . . . HELLO . . .") 22 | ;;;(72 69 76 76 79) 23 | ;;;_$ (string-trim 'VARIANT " ." " . . . HELLO . . .") 24 | ;;;# 25 | ;;;_$ (string-trim 'SAFEARRAY " ." " . . . HELLO . . .") 26 | ;;;# 27 | 28 | (include 'member-of-option-p "./common/member-of-option-p") 29 | (include 'coerce "./types/coerce") 30 | (include 'stringp-list "./strings/_stringp-list") 31 | (include 'to-variantp-string "./strings/_to-variantp-string") 32 | (include 'string-trim:sub "./strings/_string-trim") 33 | 34 | (defun string-trim (atype char-bag astring / sequence trim-chars) 35 | (if (member-of-option-p 36 | 'string-trim 37 | 'atype 38 | '(STR SLIST SYM VARIANT SAFEARRAY VECTOR) 39 | ) 40 | (progn 41 | (setq sequence (stringp-list astring) 42 | trim-chars (stringp-list char-bag) 43 | ) 44 | (coerce 45 | (to-variantp-string 46 | atype 47 | (reverse (string-trim:sub (reverse (string-trim:sub sequence)))) 48 | ) 49 | atype 50 | ) 51 | ) 52 | (exit) 53 | ) 54 | ) -------------------------------------------------------------------------------- /strings/string-upcase.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'string-upcase "./strings/string-upcase") 2 | 3 | ;;;(string-upcase atype astring start end) 4 | ;;; 5 | ;;;atype : symbol ('STR 'SLIST 'SYM or 'VARIANT 'SAFEARRAY 'VECTOR) 6 | ;;; 7 | ;;;astring : string, list, symbol, variant(string or safe-array), safe-array(integer) 8 | ;;; 9 | ;;;start : integer or nil 10 | ;;; 11 | ;;;end : integer or nil 12 | ;;; 13 | ;;;return : string or list etc. 14 | 15 | ;;; +------------------------------------------------------+ 16 | ;;; Copyright (c) 2020 manual chair japan 17 | ;;; Released under the MIT license 18 | ;;; https://opensource.org/licenses/mit-license.php 19 | ;;; +------------------------------------------------------+ 20 | 21 | ;;;_$ (string-upcase 'STR "hey! you are cool." nil nil) 22 | ;;;"HEY! YOU ARE COOL." 23 | ;;;_$ (string-upcase 'STR "hey! you are cool." 6 nil) 24 | ;;;"hey! yOU ARE COOL." 25 | ;;;_$ (string-upcase 'STR "hey! you are cool." 6 10) 26 | ;;;"hey! yOU Are cool." 27 | ;;;_$ (string-upcase 'SLIST "hey! you are cool." nil nil) 28 | ;;;(72 69 89 33 32 89 79 85 32 65 82 69 32 67 79 79 76 46) 29 | ;;;_$ (string-upcase 'VARIANT "hey! you are cool." nil nil) 30 | ;;;# 31 | ;;;_$ (string-upcase 'SAFEARRAY "hey! you are cool." nil nil) 32 | ;;;# 33 | 34 | (include 'default "./common/default") 35 | (include 'member-of-option-p "./common/member-of-option-p") 36 | (include 'coerce "./types/coerce") 37 | (include 'char-upcase "./characters/char-upcase") 38 | (include 'stringp-list "./strings/_stringp-list") 39 | (include 'to-variantp-string "./strings/_to-variantp-string") 40 | (include 'subseq-list "./sequences/subseq-list") 41 | 42 | (defun string-upcase (atype astring start end / sequence) 43 | (if (member-of-option-p 44 | 'string-upcase 45 | 'atype 46 | '(STR SLIST SYM VARIANT SAFEARRAY VECTOR) 47 | ) 48 | (progn 49 | (setq sequence (stringp-list astring) 50 | start (max 0 (default start '0)) 51 | end (min (default end '(length sequence)) (length sequence)) 52 | ) 53 | (coerce 54 | (to-variantp-string 55 | atype 56 | (append (subseq-list sequence 0 start) 57 | (mapcar 'char-upcase (subseq-list sequence start end)) 58 | (subseq-list sequence end nil) 59 | ) 60 | ) 61 | atype 62 | ) 63 | ) 64 | (exit) 65 | ) 66 | ) -------------------------------------------------------------------------------- /strings/string.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'string "./strings/string") 2 | 3 | ;;;(string item) 4 | ;;; 5 | ;;;item : string, list, symbol, variant(string or safe-array), safe-array 6 | ;;; 7 | ;;;return : string 8 | ;;; if item is string, this return itself. 9 | ;;; if item is list, this return string converted from list. 10 | ;;; if item is symbol, this return string of symbol-name. 11 | ;;; if item is safe-array, this return same string as list. 12 | ;;; if item is variant, this return same string as string or list. 13 | ;;; In other case, return nil. 14 | 15 | ;;; +------------------------------------------------------+ 16 | ;;; Copyright (c) 2020 manual chair japan 17 | ;;; Released under the MIT license 18 | ;;; https://opensource.org/licenses/mit-license.php 19 | ;;; +------------------------------------------------------+ 20 | 21 | (include 'coerce "./types/coerce") 22 | (include 'stringp "./strings/stringp") 23 | 24 | (defun string (item) 25 | (if (stringp item) 26 | (coerce item 'STR) 27 | (exit) 28 | ) 29 | ) 30 | -------------------------------------------------------------------------------- /strings/stringp.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'stringp "./strings/stringp") 2 | 3 | ;;;(stringp item) 4 | ;;; 5 | ;;;stringp : atom or list 6 | ;;; 7 | ;;;return : T or nil 8 | 9 | ;;; +------------------------------------------------------+ 10 | ;;; Copyright (c) 2020 manual chair japan 11 | ;;; Released under the MIT license 12 | ;;; https://opensource.org/licenses/mit-license.php 13 | ;;; +------------------------------------------------------+ 14 | 15 | (include 'type-of "./types/type-of") 16 | (include 'characterp "./characters/characterp") 17 | 18 | (defun stringp (item / itype) 19 | (setq itype (type-of item)) 20 | (or 21 | (= itype 'STR) 22 | (= itype 'SYM) 23 | (= itype 'NIL) 24 | (and (= itype 'LIST) (vl-every 'characterp item)) 25 | (and 26 | (= itype 'VARIANT) 27 | (or (= (vlax-variant-type item) vlax-vbString) 28 | (and 29 | (or (= (vlax-variant-type item) (+ vlax-vbArray vlax-vbInteger)) 30 | (= (vlax-variant-type item) (+ vlax-vbArray vlax-vbLong)) 31 | ) 32 | (vl-every 'characterp (coerce item 'SLIST)) 33 | ) 34 | ) 35 | ) 36 | (and (= itype 'SAFEARRAY) 37 | (and (or (= (vlax-safearray-type item) vlax-vbInteger) 38 | (= (vlax-safearray-type item) vlax-vbLong) 39 | ) 40 | (vl-every 'characterp (coerce item 'SLIST)) 41 | ) 42 | ) 43 | ) 44 | ) 45 | -------------------------------------------------------------------------------- /structures/assoclist-structure.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'assoclist->structure "./structures/assoclist-structure") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'ALValue "./conses/ALValue") 10 | (include 'concatenate "./sequences/concatenate") 11 | 12 | (defun assoclist->structure (alist / structure-name) 13 | (if (setq structure-name (ALValue alist 'STRUCTURE)) 14 | (apply 15 | (concatenate 'SYM (list 'make- structure-name)) 16 | (mapcar (function (lambda (member-name) (ALValue alist member-name))) 17 | (cdr (vl-symbol-value structure-name)) 18 | ) 19 | ) 20 | (exit) 21 | ) 22 | ) -------------------------------------------------------------------------------- /structures/structure-assoclist.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'structure->assoclist "./structures/structure-assoclist") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'structure-p "./structures/structure-p") 10 | 11 | (defun structure->assoclist (structure) 12 | (if (structure-p structure) 13 | (mapcar 'cons (eval (car structure)) structure) 14 | (exit) 15 | ) 16 | ) 17 | -------------------------------------------------------------------------------- /structures/structure-p.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'structure-p "./structures/structure-p") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (defun structure-p (item / temp) 10 | (and (vl-consp item) 11 | (= (type (car item)) 'SYM) 12 | (vl-consp (setq temp (eval (car item)))) 13 | (= (car temp) 'structure) 14 | ) 15 | ) 16 | -------------------------------------------------------------------------------- /symbols/make-handle.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'make-handle "./symbols/make-handle") 2 | 3 | ;;;(make-handle group data) 4 | ;;; 5 | ;;;group : string, list, symbol, variant(string or safe-array), safe-array(integer) 6 | ;;; 7 | ;;;data : atom or list 8 | ;;; 9 | ;;;return : symbol 10 | ;;; 11 | ;;;(release-handle handle) 12 | ;;; 13 | ;;;handle : symbol 14 | ;;; 15 | ;;;return : nil 16 | 17 | ;;; +------------------------------------------------------+ 18 | ;;; Copyright (c) 2020 manual chair japan 19 | ;;; Released under the MIT license 20 | ;;; https://opensource.org/licenses/mit-license.php 21 | ;;; +------------------------------------------------------+ 22 | 23 | ;;;_$ (setq a (make-handle "DATA" '(DATA 123 456 789))) 24 | ;;;*DATA:HND-0* 25 | ;;;_$ (vl-symbol-value a) 26 | ;;;(DATA 123 456 789) 27 | ;;;_$ (set a '(DATA +++ +++ +++)) 28 | ;;;(DATA +++ +++ +++) 29 | ;;;_$ (vl-symbol-value a) 30 | ;;;(DATA +++ +++ +++) 31 | ;;;_$ (release-handle a) 32 | ;;;nil 33 | ;;;_$ (vl-symbol-value a) 34 | ;;;nil 35 | 36 | (include 'default "./common/default") 37 | (include 'coerce "./types/coerce") 38 | (include 'ALValue "./conses/ALValue") 39 | (include 'set-ALValue "./conses/set-ALValue") 40 | (include 'concatenate "./sequences/concatenate") 41 | 42 | (setq *handleCounts* nil) 43 | 44 | (defun make-handle:increment-count (count) 45 | (if (= count 2147483647) 46 | 0 47 | (1+ count) 48 | ) 49 | ) 50 | 51 | (defun make-handle (group data / count start handle) 52 | (setq group (coerce group 'SYM) 53 | count (default (ALValue *handleCounts* group) 0) 54 | start count 55 | ) 56 | (while (boundp (setq handle 57 | (concatenate 'SYM (list "*" group ":HND-" (itoa count) "*")) 58 | ) 59 | ) 60 | (if (= (setq count (make-handle:increment-count count)) start) 61 | (progn (princ "\n ERROR : Handle count was OVERFLOW") (exit)) 62 | ) 63 | ) 64 | (setq count (make-handle:increment-count count) 65 | *handleCounts* (set-ALValue *handleCounts* group count) 66 | ) 67 | (set handle data) 68 | handle 69 | ) 70 | 71 | (defun release-handle (handle) (set handle nil)) -------------------------------------------------------------------------------- /types/AutoCAD/SSToList.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'SSToList "./types/AutoCAD/SSToList") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (defun SSToList:sub (ss index numOfEntity /) 10 | (if (< index numOfEntity) 11 | (cons (ssname ss index) (SSToList:sub ss (1+ index) numOfEntity)) 12 | ) 13 | ) 14 | 15 | (defun SSToList (ss /) 16 | (if ss 17 | (SSToList:sub ss 0 (sslength ss)) 18 | ) 19 | ) 20 | -------------------------------------------------------------------------------- /types/AutoCAD/listToSS.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'listToSS "./types/AutoCAD/listToSS") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (defun listToSS (alist / ename ss) 10 | (setq ss (ssadd)) 11 | (foreach ename alist (if ename (ssadd ename ss))) 12 | ss 13 | ) 14 | -------------------------------------------------------------------------------- /types/multibyte/_Shift_JIS.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'Shift_JIS "./types/multibyte/_Shift_JIS") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'defstruct "./structures/defstruct") 10 | 11 | (defstruct 'Shift_JIS '((code . '0))) 12 | 13 | (defun encode:Shift_JIS-p (clist) 14 | (if clist 15 | (or (and (<= 128 (car clist)) (<= (car clist) 159)) 16 | (and (<= 224 (car clist)) (<= (car clist) 255)) 17 | ) 18 | ) 19 | ) 20 | 21 | (defun encode:Shift_JIS (clist) 22 | (cons (make-Shift_JIS (+ (lsh (car clist) 8) (cadr clist))) 2) 23 | ) 24 | 25 | ;; 26 | 27 | (defun decode:Shift_JIS (Shift_JIS-s) 28 | (list (lsh (Shift_JIS-code Shift_JIS-s) -8) 29 | (logand (Shift_JIS-code Shift_JIS-s) 255) 30 | ) 31 | ) -------------------------------------------------------------------------------- /types/multibyte/_unicode.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'unicode "./types/multibyte/_unicode") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'defstruct "./structures/defstruct") 10 | (include 'padding-list "./sequences/padding-list") 11 | (include 'parse-integer-list "./numbers/parse-integer-list") 12 | (include 'plusp "./numbers/plusp") 13 | (include 'digit-char "./characters/digit-char") 14 | 15 | (defstruct 'unicode '((code . '0))) 16 | 17 | (defun encode:unicode-p (clist) 18 | (and (= (car clist) 92 ;| \ |;) 19 | (or (= (cadr clist) 85 ;| U |;) (= (cadr clist) 117 ;| u |;)) 20 | (= (caddr clist) 43 ;| + |;) 21 | ) 22 | ) 23 | 24 | (defun encode:unicode:make (clist) 25 | (make-unicode (parse-integer-list clist 0 4 16 nil)) 26 | ) 27 | 28 | (defun encode:unicode (clist) (cons (encode:unicode:make (cdddr clist)) 7)) 29 | 30 | ;; 31 | 32 | (defun decode:unicode:to-hex-string (integer / stack) 33 | (while (plusp integer) 34 | (setq stack (cons (digit-char (rem integer 16) radix) stack) 35 | integer (/ integer 16) 36 | ) 37 | ) 38 | stack 39 | ) 40 | 41 | (defun decode:unicode (unicode-s) 42 | (append '(92 85 43) ;_ \U+ 43 | (padding-list 44 | (decode:unicode:to-hex-string (unicode-code unicode-s)) 45 | 'LEFT 46 | 4 47 | nil 48 | 48 ;|(ascii "0")|; 49 | ) 50 | ) 51 | ) 52 | -------------------------------------------------------------------------------- /types/multibyte/list-string.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'list->string "./types/multibyte/list-string") 2 | 3 | ;;;(list->string clist) 4 | ;;; 5 | ;;;string : list of integer or structure of multibyte charactor 6 | ;;; 7 | ;;;return : string 8 | 9 | ;;; +------------------------------------------------------+ 10 | ;;; Copyright (c) 2020 manual chair japan 11 | ;;; Released under the MIT license 12 | ;;; https://opensource.org/licenses/mit-license.php 13 | ;;; +------------------------------------------------------+ 14 | 15 | (include '*LISPSYS* "./common/LISPSYS") 16 | (include 'plusp "./numbers/plusp") 17 | (include '*multi-byte-char:function* 18 | "./types/multibyte/multi-byte-char-func" 19 | ) 20 | 21 | (defun decode-multibytecharactor:sub (tlist) 22 | (if tlist 23 | (if (apply (read (strcat (vl-symbol-name (car tlist)) "-p")) 24 | (list item) 25 | ) 26 | (apply (multi-byte-function-decode 27 | (cdr (assoc (car tlist) *multi-byte-char:function*)) 28 | ) 29 | (list item) 30 | ) 31 | (decode-multibytecharactor:sub (cdr tlist)) 32 | ) 33 | (list item) 34 | ) 35 | ) 36 | 37 | (defun decode-multibytecharactor (item) 38 | (decode-multibytecharactor:sub 39 | (mapcar 'car *multi-byte-char:function*) 40 | ) 41 | ) 42 | 43 | (setq list->string 44 | (if (plusp *LISPSYS*) 45 | vl-list->string 46 | (lambda (clist) 47 | (vl-list->string 48 | (apply 'append 49 | (mapcar 'decode-multibytecharactor clist) 50 | ) 51 | ) 52 | ) 53 | ) 54 | ) -------------------------------------------------------------------------------- /types/multibyte/multi-byte-char-compare.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'multi-byte-char:compare "./types/multibyte/multi-byte-char-compare") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'type-of "./types/type-of") 10 | (include 'defstruct "./structures/defstruct") 11 | (include 'concatenate "./sequences/concatenate") 12 | (include '*multi-byte-char:types* 13 | "./types/multibyte/multi-byte-char-types" 14 | ) 15 | 16 | (defun multi-byte-char:compare:same-type (/ func-code) 17 | (setq func-code (concatenate 18 | 'SYM 19 | (list mtype1 '(45 99 111 100 101) ;|"-code"|;) 20 | ) 21 | ) 22 | (- (apply func-code (list mchar1)) (apply func-code (list mchar2))) 23 | ) 24 | 25 | (defun multi-byte-char:compare (mchar1 mchar2 / mtype1 mtype2) 26 | (if (= (setq mtype1 (type-of mchar1)) 27 | (setq mtype2 (type-of mchar2)) 28 | ) 29 | (multi-byte-char:compare:same-type) 30 | (if (member (type-of char1) 31 | (member (type-of char2) *multi-byte-char:types*) 32 | ) 33 | 1 34 | -1 35 | ) 36 | ) 37 | ) -------------------------------------------------------------------------------- /types/multibyte/multi-byte-char-func.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include '*multi-byte-char:function* "./types/multibyte/multi-byte-char-func") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'defstruct "./structures/defstruct") 10 | (include 'unicode "./types/multibyte/_unicode") 11 | (include 'Shift_JIS "./types/multibyte/_Shift_JIS") 12 | 13 | (defstruct 'multi-byte-function 14 | '((predicate) (encode) (decode)) 15 | ) 16 | 17 | (setq *multi-byte-char:function* 18 | (list (cons 'Shift_JIS 19 | (make-multi-byte-function 20 | 'encode:Shift_JIS-p 21 | 'encode:Shift_JIS 22 | 'decode:Shift_JIS 23 | ) 24 | ) 25 | (cons 'UNICODE 26 | (make-multi-byte-function 27 | 'encode:unicode-p 28 | 'encode:unicode 29 | 'decode:unicode 30 | ) 31 | ) 32 | ) 33 | ) 34 | 35 | -------------------------------------------------------------------------------- /types/multibyte/multi-byte-char-p.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'multi-byte-char-p "./types/multibyte/multi-byte-char-p") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include 'defstruct "./structures/defstruct") 10 | (include 'structure-p "./structures/structure-p") 11 | (include '*multi-byte-char:types* "./types/multibyte/multi-byte-char-types") 12 | 13 | (defun multi-byte-char-p (item) 14 | (and (structure-p item) 15 | (member (car item) *multi-byte-char:types*) 16 | ) 17 | ) 18 | -------------------------------------------------------------------------------- /types/multibyte/multi-byte-char-types.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include '*multi-byte-char:types* "./types/multibyte/multi-byte-char-types") 2 | 3 | ;;; +------------------------------------------------------+ 4 | ;;; Copyright (c) 2020 manual chair japan 5 | ;;; Released under the MIT license 6 | ;;; https://opensource.org/licenses/mit-license.php 7 | ;;; +------------------------------------------------------+ 8 | 9 | (include '*ISO-639-1* "./common/ISO-639-1") 10 | (include 'default "./common/default") 11 | 12 | (setq *multi-byte-char:locale* '((JA Shift_JIS UNICODE) (EN UNICODE))) 13 | 14 | ;; 15 | 16 | (setq *multi-byte-char:types* 17 | (default 18 | (cdr 19 | (assoc *ISO-639-1* *multi-byte-char:locale*) 20 | ) 21 | '(quote (UNICODE)) 22 | ) 23 | ) 24 | -------------------------------------------------------------------------------- /types/multibyte/string-list.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'string->list "./types/multibyte/string-list") 2 | 3 | ;;;(string->list string) 4 | ;;; 5 | ;;;string : string 6 | ;;; 7 | ;;;return : list of integer or structure of multibyte charactor 8 | 9 | ;;; +------------------------------------------------------+ 10 | ;;; Copyright (c) 2020 manual chair japan 11 | ;;; Released under the MIT license 12 | ;;; https://opensource.org/licenses/mit-license.php 13 | ;;; +------------------------------------------------------+ 14 | 15 | (include '*LISPSYS* "./common/LISPSYS") 16 | (include 'plusp "./numbers/plusp") 17 | (include 'nthcdr "./conses/nthcdr") 18 | (include '*multi-byte-char:function* 19 | "./types/multibyte/multi-byte-char-func" 20 | ) 21 | 22 | (defun encode-multibytecharactor:sub (clist tlist / func-s) 23 | (if tlist 24 | (progn 25 | (setq func-s (cdr (assoc (car tlist) *multi-byte-char:function*))) 26 | (if (apply (multi-byte-function-predicate func-s) (list clist)) 27 | (apply (multi-byte-function-encode func-s) (list clist)) 28 | (encode-multibytecharactor:sub clist (cdr tlist)) 29 | ) 30 | ) 31 | (cons (car clist) 1) 32 | ) 33 | ) 34 | 35 | (defun encode-multibytecharactor (clist) 36 | (encode-multibytecharactor:sub 37 | clist 38 | *multi-byte-char:types* 39 | ) 40 | ) 41 | 42 | (defun string->list:sub (clist) 43 | (if clist 44 | (progn (setq char-info (encode-multibytecharactor clist)) 45 | (cons (car char-info) 46 | (string->list:sub (nthcdr (cdr char-info) clist)) 47 | ) 48 | ) 49 | ) 50 | ) 51 | 52 | (setq string->list 53 | (if (plusp *LISPSYS*) 54 | vl-string->list 55 | (lambda (astring) 56 | (if astring 57 | (string->list:sub (vl-string->list astring)) 58 | ) 59 | ) 60 | ) 61 | ) -------------------------------------------------------------------------------- /types/type-of.LSP: -------------------------------------------------------------------------------- 1 | ;;;(include 'type-of "./types/type-of") 2 | 3 | ;;;(type-of item) 4 | ;;; 5 | ;;;item : atom or list 6 | ;;; 7 | ;;;return : Data-type symbol of item 8 | 9 | ;;; +------------------------------------------------------+ 10 | ;;; Copyright (c) 2020 manual chair japan 11 | ;;; Released under the MIT license 12 | ;;; https://opensource.org/licenses/mit-license.php 13 | ;;; +------------------------------------------------------+ 14 | 15 | (include 'structure-p "./structures/structure-p") 16 | 17 | (defun type-of (item / atype) 18 | (setq atype (type item)) 19 | (cond ((= atype 'LIST) 20 | (if (structure-p item) 21 | (car item) 22 | atype 23 | ) 24 | ) 25 | (T atype) 26 | ) 27 | ) 28 | -------------------------------------------------------------------------------- /types/typep.lsp: -------------------------------------------------------------------------------- 1 | ;;;(include 'typep "./types/typep") 2 | 3 | ;;;(typep item type-symbol) 4 | ;;; 5 | ;;;item : atom or list 6 | ;;; 7 | ;;;type-symbol : symbol of Data-type 8 | ;;; 9 | ;;;return : T or nil 10 | 11 | ;;; +------------------------------------------------------+ 12 | ;;; Copyright (c) 2020 manual chair japan 13 | ;;; Released under the MIT license 14 | ;;; https://opensource.org/licenses/mit-license.php 15 | ;;; +------------------------------------------------------+ 16 | 17 | (include 'type-of "./types/type-of") 18 | 19 | (defun typep (item type-symbol) 20 | (= (type-of item) type-symbol) 21 | ) --------------------------------------------------------------------------------