From: SALOMAKI@jylk.jyu.fi (SALOM{KI KARI JUHANI, FYS)
Subject: Lisp functions
Organization: University of Jyvaskyla
Date: Tue, 12 Jan 1993 06:27:00 GMT
X-News-Reader: VMS NEWS 1.20

;
;    Here comes some AutoLISP functions
;

;*    *    *    *    *    *    *    *    *    *    *    *    *    *    *
;*    Kari Salomaki                                                    *
;*    production engineer                                              *
;*                                                                     *
;*    University of Jyvaskyla       tel.      +358-41-602 420          *
;*    Accelerator laboratory        fax.      +358-41-602 401          *
;*    P.O. Box 35                   Internet: SALOMAKI@JYFL.JYU.FI     *
;*    SF-40351  Jyvaskyla           Internet: SALOMAKI@JYLK.JYU.FI     *
;*    FINLAND                                                          *
;*    *    *    *    *    *    *    *    *    *    *    *    *    *    *

;
;	LIST OF FUNCTIONS
;
;**   **   **   **   **   **   **   **   **   **   **   **   **
;**   MATHEMATICAL FUNCTIONS
;**   **   **   **   **   **   **   **   **   **   **   **   **

;ACOS.LSP       Function to calculate inverse cosine
;ASIN.LSP       Function to calculate inverse sine
;LOG10.LSP      Function to calculate base-10 logarithm
;LOGK.LSP       Function to calculate base-k logarithm
;ROUND.LSP      Function to round number with given accuracy
;SGN.LSP        Function to get numbers sign
;SQR.LSP        Function to calculate nths root
;TAN.LSP        Function to calculate tangent


;**   **   **   **   **   **   **   **   **   **   **   **   **
;**   CONVERSION FUNCTIONS
;**   **   **   **   **   **   **   **   **   **   **   **   **

;HEX2INT.LSP    Function to convert hexadecimal to integer
;INT2HEX.LSP    Function to convert integer to hexadecimal
;OCT2INT.LSP    Function to convert octal value to integer
;INT2OCT.LSP    Function to convert integer to octal value
;BIN2INT.LSP    Function to convert binary value to integer
;INT2BIN.LSP    Function to convert integer to binary value


;**   **   **   **   **   **   **   **   **   **   **   **   **
;**   LIST FUNCTIONS
;**   **   **   **   **   **   **   **   **   **   **   **   **

;ADDLIST.LSP    Adds item to list first element 
;               if item not already exist in the list
;LISTMANI.LSP   List manipulation 
;               Creates list which contains subtractions,
;               intersection and union of two lists
;NTHS.LSP       Function to get element place from list
;REMLIST.LSP    Removes list items from other list
;ROLLER.LSP     Moves last element of the list to the first
;               or first element of the list to the last
;               depending of the given mode
;SORT.LSP       Sorts list numerical elements to ascending order


;**   **   **   **   **   **   **   **   **   **   **   **   **
;**   STRING FUNCTIONS
;**   **   **   **   **   **   **   **   **   **   **   **   **

;DATE$.LSP      Function to make different datums


;**   **   **   **   **   **   **   **   **   **   **   **   **
;**   DRAWING FUNCTIONS
;**   **   **   **   **   **   **   **   **   **   **   **   **

;ARLINE.LSP     Function to draw arrowline (like leader)


;**   **   **   **   **   **   **   **   **   **   **   **   **
;**   MISCELLANEOUS FUNCTIONS
;**   **   **   **   **   **   **   **   **   **   **   **   **

;BEEP.LSP       Function to generate beep


;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    AutoLISP programs for AutoCAD rel.11
;    
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;
;    Copyright:          Kari Salomaki
;                        University of Jyvaskyla
;                        Department of Physics
;                        Internet: SALOMAKI@JYFL.JYU.FI
;    
;    Date:               January 1993
;    
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;
;    These programs are provided "as is" without ANY warranties.
;
;    AutoLISP and AutoCAD are registered trademarks of AutoDesk, Inc.
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       ACOS.LSP
;    
;    Description:        Function to calculate inverse cosine
;
;    Syntax :  (ACos <numerical value between -1 and 1>)
;
;    Call :    (ACos 0.5)
;    Returns : 1.0472
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN ACos (x)

     (IF (NUMBERP x)
     (PROGN
          (SETQ x (FLOAT x))
          (COND 
                ((AND (> x 0)(<= x 1))
                    (ATAN (/ (SQRT (- 1 (* x x))) x)))
                ((AND (>= x (- 1))(< x 0))
                    (+ pi (ATAN (/ (SQRT (- 1 (* x x))) x))))
                ((= x 0)
                    (/ pi 2))
          )
     )
     'NIL
     )
)

;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       ADDLIST.LSP
;    
;    Description:        Adds item to list first element 
;                        if not already exist in the list
;
;    Syntax :  (AddList <item> <list>)
;
;    Call :    (AddList 'ABC '(DEF GHI JKL))
;    Returns : (ABC DEF GHI JKL)
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN AddList (item lst)

     (IF (LISTP lst)
          (COND 
                    ((NOT (MEMBER item lst))(CONS item lst))
                    (T lst)
          )
          'NIL
     )
)

;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       ARLINE.LSP
;    
;    Description:        Function to draw arrowline (like leader)
;    
;    Syntax :  (ArLine <list of points>)
;    Notice :  list must include at least two points
;
;    Call :    (ArLine '((10 10)(50 50)....))
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;
;    Functions to load before calling this function:
;
;    Tan       - Function to calculate tangent
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN ArLine (plis / arang arlen arwid arpt i p ComLin PtLis)

     (SETQ ptlist '(pt1 pt0))
     (SETQ pt0 (NTH 0 plis))
     (SETQ pt1 (NTH 1 plis))
     (SETQ arang (ANGLE pt0 pt1)
           arlen (* (GETVAR "DIMASZ")(GETVAR "DIMSCALE"))
           arwid (* 2 (Tan 0.1651) arlen)
           arpt (POLAR pt0 arang arlen))
     (SETVAR "CMDECHO" 0)
     (SETQ i 0)
     (SETQ ComLin '(COMMAND "PLINE" pt0 "W" 0 arwid arpt "W" 0 0 pt1 ))
     (IF (> (LENGTH plis) 2)
          (PROGN
               (SETQ i 1)
               (REPEAT (- (LENGTH plis) 2)
                    (SETQ i (+ i 1))
                    (SETQ p (READ (STRCAT "pt" (ITOA i))))
                    (SETQ PtList (CONS p PtList))
                    (SET p (NTH i plis))
                    (SETQ ComLin (APPEND ComLin (LIST p)))
               )
          )
     )
     (SETQ ComLin (APPEND ComLin (LIST "")))
     (EVAL ComLin)
     (MAPCAR '(LAMBDA (x) (SET x NIL)) PtList)
     (SETVAR "CMDECHO" 1)
)

;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       ASIN.LSP
;    
;    Description:        Function to calculate inverse sine
;    
;    Syntax :  (ASin <numerical value between -1 and 1>)
;
;    Call :    (Asin 0.5)
;    Returns : 0.523599
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN ASin (x)

     (IF (NUMBERP x)
          (PROGN
               (SETQ x (FLOAT x))
               (COND 
                     ((AND (>= x 0)(< x 1))
                         (ATAN (/ X (SQRT (- 1 (* x x))))))
                     ((AND (< x 0)(> x (- 1)))
                         (- (ATAN (/ X (SQRT (- 1 (* x x)))))))
                     ((= x 1)
                         (/ pi 2))
                     ((= x (- 1))
                         (- (/ pi 2)))
               )
          )
          'NIL
     )
)

;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       BEEP.LSP
;    
;    Description:        Function to generate beep
;
;    Syntax :  (Beep)
;
;    Call :    (Beep)
;    Returns : Nothing
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN beep ()
     (SETQ f (OPEN "CON" "w"))
          (PRINC (CHR 7) f)
     (CLOSE f)
     (PRINC)
)

;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       BIN2INT.LSP
;    
;    Description:        Convert binary to integer
;    
;    Syntax :  (Bin2Int <string>)
;
;    Call :    (Bin2Int "101101")
;    Returns : 45
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN Bin2Int (BinStr / Dummy i)

     (IF (= (TYPE BinStr) 'STR)
          (PROGN
          (SETQ Dummy 0 i 0)
          (REPEAT (STRLEN BinStr)
               (SETQ Dummy (* 2 Dummy))
               (SETQ i (1+ i))
               (IF (EQUAL (SUBSTR BinStr i 1) "1")
                    (SETQ Dummy (1+ Dummy))
               )
          )
          Dummy
          )
          'NIL
     )
)

;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       DATE$.LSP
;    
;    Description:        Function to make different datums
;    
;    Syntax :  (Date$ <numerical value>)
;    Call :    (Date$ 0)
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;
;    mode = 0       dd.mm.yyyy     date.month.year
;    mode = 1       dd.mm.yy       date.month.year
;    mode = 2       dd-mm-yyyy     date-month-year
;    mode = 3       dd-mm-yyyy     date-month-year
;    mode = 4       yyyy-mm-dd     year-month-date
;    mode = 5       yy-mm-dd       year-month-date
;    mode = 6       ddmmyy         date month year
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN Date$ (mode / yyyy yy mm dd date)

     (SETQ date (FIX (GETVAR "CDATE")))
     (SETQ yyyy (FIX (/ date 10000))
           yy (- yyyy (* (FIX (/ yyyy 100)) 100))
           mm (FIX (/ (- date (* yyyy 10000)) 100))
           dd (- date (* yyyy 10000)(* mm 100))
           yyyy (ITOA yyyy)
           yy (ITOA yy)
           mm (ITOA mm)
           dd (ITOA dd)
     )
     (IF (< (STRLEN yy) 2)
          (SETQ yy (STRCAT "0" yy))
     )
     (IF (< (STRLEN mm) 2)
          (SETQ mm (STRCAT "0" mm))
     )
     (IF (< (STRLEN dd) 2)
          (SETQ dd (STRCAT "0" dd))
     )

     (COND ((= mode 0)(STRCAT dd "." mm "." yyyy))
           ((= mode 1)(STRCAT dd "." mm "." yy))
           ((= mode 2)(STRCAT dd "-" mm "-" yyyy))
           ((= mode 3)(STRCAT dd "-"  mm "-" yy))
           ((= mode 4)(STRCAT yyyy "-" mm "-" dd))
           ((= mode 5)(STRCAT yy "-" mm "-" dd))
           ((= mode 6)(STRCAT dd mm yy))
     )

)

;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       HEX2INT.LSP
;    
;    Description:        Function to convert hexadecimal to integer
;    
;    Syntax :  (Hex2Int <string>)
;
;    Call :    (Hex2Int "100")
;    Returns : 256
;    Call :    (Hex2Int "FFFF")
;    Returns : 65535
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;
;    Functions to load before calling this function:
;
;    Nths      - Function to get element place from list
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN Hex2Int (HexStr / CvrtStr i Dummy)

     (IF (= (TYPE HexStr) 'STR)
     (PROGN
     (SETQ 
     HexStr (STRCASE HexStr)
     CvrtStr '("0""1""2""3""4""5""6""7""8""9""A""B""C""D""E""F")
     i 0
     Dummy 0
     )
     (REPEAT (STRLEN HexStr)
          (SETQ i (1+ i))
          (SETQ Dummy 
               (+ Dummy (* (Nths (SUBSTR HexStr i 1) CvrtStr) 
               (EXPT 16 (- (STRLEN HexStr) i)))
               )
          )
     )
     )
     'NIL
     )
)

;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       INT2BIN.LSP
;    
;    Description:        Convert integer to binary
;
;    Syntax :  (Int2Bin <numerical value>)
;
;    Call :    (Int2Bin 45)
;    Returns : "101101"
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;
;    Functions to load before calling this function:
;
;    Bin2Int   - Function to convert binary to integer
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN Int2Bin (IntNro / BinStr i)

     (IF (NUMBERP IntNro)
          (PROGN
          (SETQ BinStr "" i 0)
          (WHILE (NOT (EQUAL i 16))
               (IF (> (LOGAND IntNro (EXPT 2 i)) 0)
                    (SETQ BinStr (STRCAT "1" BinStr))
                    (SETQ BinStr (STRCAT "0" BinStr))
               )
               (IF (EQUAL (Bin2Int BinStr) IntNro)
               (SETQ i 16)
               (SETQ i (1+ i))
               )
          )
          BinStr
          )
          'NIL
     )
)

;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       INT2HEX.LSP
;    
;    Description:        Function to convert integer to hexadecimal
;    
;    Syntax :  (Int2Hex <numerical value>)
;
;    Call :    (Int2Hex 256)
;    Returns : "100"
;    Call :    (Int2Hex 65535)
;    Returns : "FFFF"
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN Int2Hex (IntNro / CvrtStr i Dummy)

(IF (AND (NUMBERP IntNro)(< IntNro 65536))
     (PROGN
     (SETQ
     IntNro (FIX IntNro)
     CvrtStr '("0""1""2""3""4""5""6""7""8""9""A""B""C""D""E""F")
     i 4
     Dummy ""
     )
          (REPEAT 3
               (SETQ i (1- i))
               (IF (NOT (AND (ZEROP (FIX (/ IntNro (EXPT 16 i))))(= Dummy "")))
               (SETQ 
               Dummy (STRCAT Dummy (Nth (FIX (/ IntNro (EXPT 16 i))) CvrtStr))
               IntNro (- IntNro (* (FIX (/ IntNro (EXPT 16 i)))(EXPT 16 i)))
               )
               )
          )
          (SETQ Dummy (STRCAT Dummy (Nth IntNro CvrtStr)))
     )
     'NIL
)
)

;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       INT2OCT.LSP
;    
;    Description:        Function to convert integer to octal value
;    
;    Syntax :  (Int2Oct <numerical value>)
;
;    Call :    (Int2Oct 64)
;    Returns : "100"
;    Call :    (Int2Oct 127)
;    Returns : "177"
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN Int2Oct (IntNro / CvrtStr i Dummy)

(IF (AND (NUMBERP IntNro)(< IntNro 65536))
     (PROGN
     (SETQ
     IntNro (FIX IntNro)
     CvrtStr '("0""1""2""3""4""5""6""7")
     i 6
     Dummy ""
     )
          (REPEAT 5
               (SETQ i (1- i))
               (IF (NOT (AND (ZEROP (FIX (/ IntNro (EXPT 8 i))))(= Dummy "")))
               (SETQ 
               Dummy (STRCAT Dummy (Nth (FIX (/ IntNro (EXPT 8 i))) CvrtStr))
               IntNro (- IntNro (* (FIX (/ IntNro (EXPT 8 i)))(EXPT 8 i)))
               )
               )
          )
          (SETQ Dummy (STRCAT Dummy (Nth IntNro CvrtStr)))
     )
     'NIL
)
)

;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       LISTMANI.LSP
;    
;    Description:        List manipulation 
;                        Creates list which contains subtractions,
;                        intersection and union of two lists
;
;    Syntax :  (ListMani <list1> <list2>)
;    Return :  (<subtraction list1 list2>
;               <subtraction list2 list1>
;               <intersection list1 list2>
;               <union list1 list2>)
;
;    Call :    (ListMani '(A B C D E F) '(D E F G H I))
;    Returns : ((A B C) (G H I) (D E F) (A B C D E F G H I))
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN ListMani (lst1 lst2 / lst3 lst4 lst5 lst6)

     (IF (AND (LISTP lst1)(LISTP lst2))
          (PROGN
               (SETQ lst3 '() lst4 '() lst5 '() lst6'())
               (FOREACH item lst1
                    (IF (NOT (MEMBER item lst2))
                         (SETQ lst3 (CONS item lst3))
                         (SETQ lst5 (CONS item lst5))
                    )
                    (SETQ lst6 (CONS item lst6))
               )
               (FOREACH item lst2
                    (IF (NOT (MEMBER item lst1))
                         (SETQ lst4 (CONS item lst4))
                    )
                    (IF (NOT (MEMBER item lst6))
                         (SETQ lst6 (CONS item lst6))
                    )
               )
               
               (LIST 
                    (REVERSE lst3)
                    (REVERSE lst4)
                    (REVERSE lst5)
                    (REVERSE lst6)
               )
          )
     'NIL
     )
)

;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       LOG10.LSP
;    
;    Description:        Function to calculate base-10 logarithm
;    
;    Syntax :  (Log10 <numerical value>)
;
;    Call :    (Log10 10000)
;    Returns : 4.0
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN Log10 (x)

     (IF (NUMBERP x)
          (/ (LOG (FLOAT x)) (LOG 10.0))
          'NIL
     )
)

;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       LOGK.LSP
;    
;    Description:        Function to calculate base-k logarithm
;    
;    Syntax :  (LogK <numerical value><numerical value>)
;
;    Call :    (LogK 5 27)
;    Returns : 
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN LogK (k x)

     (IF (AND (NUMBERP x)(NUMBERP k))
          (/ (LOG (FLOAT x)) (LOG (FLOAT k)))
          'NIL
     )
)

;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       NTHS.LSP
;    
;    Description:        Function to get element place from list
;    
;    Syntax :  (Nths <item> <list>)
;
;    Call :    (Nths 'C '(A B C D E F G))
;    Returns : 2
;    Notice :  number of list first element is 0
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN Nths (elem lst)

     (IF (TYPE lst 'LIST)
          (PROGN
               (IF (MEMBER elem lst)
                    (-
                    (LENGTH lst)
                    (LENGTH (MEMBER elem lst))
                    )
                    NIL
               )
          )
     'NIL
     )
)

;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       OCT2INT.LSP
;    
;    Description:        Function to convert octal value to integer
;    
;    Syntax :  (Oct2Int <string>)
;
;    Call :    (Oct2Int "10")
;    Returns : 8
;    Call :    (Oct2Int "177")
;    Returns : 127
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;
;    Functions to load before calling this function:
;
;    Nths      - Function to get element place from list
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN Oct2Int (OctStr / CvrtStr i Dummy)

     (IF (= (TYPE OctStr) 'STR)
          (PROGN
          (SETQ 
          OctStr (STRCASE OctStr)
          CvrtStr '("0""1""2""3""4""5""6""7")
          i 0
          Dummy 0
          )
          (REPEAT (STRLEN OctStr)
               (SETQ i (1+ i))
               (SETQ Dummy 
                    (+ Dummy (* (Nths (SUBSTR OctStr i 1) CvrtStr) 
                    (EXPT 8 (- (STRLEN OctStr) i)))
                    )
               )
          )
          )
          'NIL
     )
)

;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       REMLIST.LSP
;    
;    Description:        Removes list items from other list
;    
;    Syntax :  (Remlist <list to remove from> <list to remove>)
;
;    Call :    (Remlist '(A B C D E F) '(A B))
;    Returns : (C D E F)
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN RemList (lst1 lst2 / item lst3)

     (IF (AND (LISTP lst1)(LISTP lst2))
          (PROGN
               (SETQ lst3 '())
               (FOREACH item lst1
                    (IF (NOT (MEMBER item lst2))
                         (SETQ lst3 (CONS item lst3))
                    )
               )
               (REVERSE lst3)
          )
          'NIL
     )
)

;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       ROLLER.LSP
;    
;    Description:        Moves last element of the list to the first
;                        or first element of the list to the last
;                        depending of the given mode
;    
;    Syntax :  (Roller <mode> <list>)
;
;    Mode :    0 ==> last element to first
;              1 ==> first element to last 
;
;    Call :    (Roller 0 '(A B C D E F G))
;    Returns : (G A B C D E F)
;    Call :    (Roller 1 '(A B C D E F G))
;    Returns : (B C D E F G A)
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN Roller (mode lst)

     (IF (LISTP lst)
          (COND ((= mode 0)
                    (CONS (CAR (REVERSE lst))(REVERSE (CDR (REVERSE lst)))))
                ((= mode 1)
                    (APPEND (CDR lst)(LIST (CAR lst))))
          )
          'NIL
     )
)

;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       ROUND.LSP
;    
;    Description:        Function to round number with given accuracy
;    
;    Syntax :  (Round <numerical value><numerical value>)
;
;    Call :    (Round 0.515545 3)
;    Returns : 0.516
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN Round (x y)

     (IF (AND (NUMBERP x)(NUMBERP y)(> y 0))
          (/ 
               (FIX (+ (* (FLOAT x)(EXPT 10 (FLOAT y))) 0.5))
               (EXPT 10 (FLOAT y))
          )
          'NIL
     )
)

;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       SGN.LSP
;    
;    Description:        Function to get numbers sign (+1, 0 or -1)
;    
;    Syntax :  (Sgn <numerical value>)
;
;    Call :    (Sgn -0.5)
;    Returns : -1
;    Call :    (Sgn 0.5)
;    Returns : 1
;    Call :    (Sgn 0.0)
;    Returns : 0
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN Sgn (x)

     (IF (NUMBERP x)
          (COND ((MINUSP x) -1)
                ((ZEROP x) 0)
                ('T 1)
          )
          'NIL
     )
)

;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       SORT.LSP
;    
;    Description:        Sorts list numerical elements to ascending order
;
;    Syntax :  (Sort <list of numerical values>)
;
;    Call :    (Sort '(0.5 2.3 100 5.2 -1.1))
;    Returns : (-1.1 0.5 2.3 5.2 100)
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;
;    Add on functions:
;
;    InsFirst    - Function to insert item to list first element
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN Sort (lst)

     (COND 
          ((NULL lst) NIL)
          (T (InsFirst (CAR lst)(Sort (CDR lst))))
     )
)

(DEFUN InsFirst (item lst)

     (COND 
          ((NULL lst)(LIST item))
          ((< ITEM (CAR lst))(CONS item lst))
          (T (CONS (CAR lst)(InsFirst item (CDR lst))))
     )
)

;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       SQR.LSP
;    
;    Description:        Function to calculate nths root
;
;    Syntax :  (Sqr <posit.nonzero numerical value> <p.n. num. value>)
;
;    Call :    (Sqr 27.0 3.0)
;    Returns : 3.0
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN Sqr (x y)

     (IF (AND (NUMBERP x)(NUMBERP y)(> x 0 )(> y 0))
          (EXPT (FLOAT x) (/ 1 (FLOAT y)))
          'NIL
     )
)

;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****
;    
;    Program name:       TAN.LSP
;    
;    Description:        Function to calculate tangent
;
;    Syntax :  (Tan <numerical value as radians>)
;
;    Call :    (Tan 0.5)
;    Retrns :  0.546302
;
;    ****  **  ****  **  ****  **  ****  **  ****  **  ****  **  ****


(DEFUN Tan (x)

     (IF (NUMBERP x)
               (/ (SIN (FLOAT x))(COS (FLOAT x)))
          NIL
     )
)