Time bound Lisp

August 8, 2018

More like this

(defun SpeakSapi ( s / sapi )
(if (eq (type s) 'STR) 
(progn 
(setq sapi (vlax-create-object "Sapi.SpVoice"))
(vlax-put sapi 'SynchronousSpeakTimeout 1)
(vlax-invoke-method sapi 'WaitUntilDone 0)
(vlax-invoke sapi "Speak" s 0)
(vlax-release-object sapi)
)))
(defun c:sample ( )
(if (> (rtos (getvar "cdate") 2 0) "20180117")
(progn
(speaksapi "Welcome from BIG al the humour and respect you can expect here at Cad tutor")
(speaksapi "PLEASE PAY YOUR MONEY")
(speaksapi "I know you have wound the clock back" )
(speaksapi "Call me on 1234 5678 if you like the software")
)
)
; do your thing here
)

August 8, 2018

Thanks Bigal will try that one...

but most of the guys here are not using pc speakers so i prefer the screen alert.

EDIT :

It's working now, thanks for Bigal's assistance but im still having this error at the end

; error: quit / exit abort

Both (exit) and (quit) commands return the "; error: quit / exit abort" message by design. Add a small error trap to hide from user if desired.

I am not that knowledgeable in lisp, can you show me an example of error trap for this?

Edited August 8, 2018 by CAD_Noob

August 10, 2018

Cad_Noob

Please see sample timebomb application that I was playing with a few years ago after seeing a few posts on the subject. It is based on an idea posted by Irne Barnard, and uses an internet date check developed by Lee Mac to beat the 'reset PC clock' problem as an alternate to what BigAl has posted.

The routine has a sample internal error handler, and includes some other subroutines for checking the date (as well as date entry).

Run 'TestTimeBomb' to demonstrate, and test using a few different dates to test against.

; Sample timebomb application
; KJM - Dec 2009
; Used to stop a routine from running if date has been exceeded


(defun C:TestTimeBomb ( / *error* )
; Test function for 'CheckProgramExpire' timebomb
; KJM - Dec 2009

; Specify special error trap for this routine
(setq OldErrorTrap *error*)
(defun *error*  (msg)
(if (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
  (progn
  	; add final error message here
  	(princ (strcat "\n*** Error: " msg " **"))
  	(princ)
  )
)
(princ)
)


; Get a data
(setq MyTestDate (getdatestring nil nil))
(prompt "\n  Date entered = ")(princ MyTestDate)(princ)

; Add expiry data in YYYYMODD format and contact info message here
(setq MyCode (CheckProgramExpire (atoi MyTestDate) "Contact XYZZY for renewal at xyzzy@nospam.net or xxx.xxx.xxxx"))
;(prompt "\nReturned Code: ")(princ MyCode)
;(princ)

; Terminate routine if expired
(if (eq MyCode 0)
 (progn
 	(prompt "\n")
 	; add additional error messages here
 	(princ)
 	(exit)	
 )
)

; Routine continues if not expired
(prompt "\nProgram continues here...")
(princ)

; Remove special error trap, restore original
(setq *error* OldErrorTrap)

)
(prompt "\nTestTimeBomb - test time bomb routine to stop program execution.")(princ)




(defun CheckProgramExpire (ExpiryDate RenewString / CurrentDate OutCode)
; Expiration date
; KJM - Dec 2009, based on code by Irne Barnard
; http://forums.augi.com/showthread.php?80070-Code-help&p=842603&viewfull=1#post842603
; Input:
;	ExpiryDate - (integer) format YYYYMODD
;	RenewString - (string) info for contact info on timer failure (nil to omit)
; Returns:
;	0 if failed
;	1 if passed
;	prints 'Program Expiry' message to command line

(setq CurrentDate (atoi (LM:InternetTime "YYYYMODD")))		; Mod KJM Jan 2012
;(setq CurrentDate (getvar "CDATE"))				; Orig version

(prompt "Checking date ... ")(princ)

(if (> CurrentDate ExpiryDate)
 (progn
 	(prompt "\n*** Program Expired ***")(princ)
 	(if RenewString
  (progn
  	(prompt (strcat "\n" RenewString))
	(princ)
  )
)
(setq OutCode 0)
 )
 (progn
(princ (strcat "\n*** Program active for " (itoa (fix (- ExpiryDate CurrentDate))) " more day(s) *** "))
(princ)
(setq OutCode 1)
 )
)

OutCode
)




(defun GetDateString (MyPrompt Default / Data)
; Get Date as a "YYYYMMDD" string and validate
; KJM - Sept 1991
; Input:
;	DataPrompt - (string) prompt, is nil use default "Enter date in YYYYMMDD format"
;	Default - default value, if nil use (rtos (getvar "cdate") 2 0) to supply current date
; Returns:
;	string in "YYYYMMDD" format



; Use default prompt if none provided
(if (eq MyPrompt nil)
(setq MyPrompt "Enter data in YYYYMMDD format")
)

; Use current date if none provided
(if (eq Default nil)
(setq Default (substr (rtos (getvar "cdate") 2 0) 1 )
)	

(setq k 1)
(while k
(prompt (strcat "\n" MyPrompt " <"))
(princ Default)(princ)

(setq Data (getstring ">: "))
(if (= Data "")
  (progn
	; Use default date, stop loop
	(setq Data Default setq k nil)
  )
  (progn
	; Validate date (8 characters + all numeric)
	(if (and (eq (strlen Data)  (numberp (atoi Data)))
	  (progn
		(setq OKYear 0 OKMonth 0 OKDay 0)		; default to incorrect
	
		(setq MyYear (atoi (substr Data 1 4)))
		(setq LeapYear (IsLeapYear MyYear))		; check if year is leap year using custom function
		(setq MyMonth (atoi (substr Data 5 2)))
		(setq MyDay (atoi (substr Data 7 2)))
		
		; Check year (adjust year limits as required)
		(if (and (>= MyYear 1900) (<= MyYear 2101))
			(setq OKYear 1)
		)
		
		; Check month between 1 and 12
		(if (and (>= MyMonth 1) (<= MyMonth 12))
			(setq OKMonth 1)
		)
		
		; Check day
		(setq DaysInMonthList (list 31 28 31 30 31 30 31 31 30 31 30 31))
		
		(if (and (eq MyMonth 2) (eq IsLeapYear 1))
		  (progn
			; Leap year check for February
			(if (and (>= MyDay 1) (<= MyDay 29))
				(setq OKDay 1)
			)	
		  )
		  (progn
		  	; Not a leap year
		  	(if (and (>= MyDay 1) (<= MyDay (nth (1- MyMonth) DaysInMonthList)))
		  		(setq OKDay)
			)
		  )
		)
		
		; Validated!
		(if (and (eq OKYear 1) (eq OKMonth 1) (eq OKDay 1))
	  		(setq k nil)	; stop loop
		)
	
	  )
	)	
  )
)
) ; close while	

Data
)


(defun IsLeapYear (Year / )
; Test for leap year, may not be valid pre 1600?
; KJM - Jan 1989
; Input:
;	Year = (integer) repesenting the year to check
; Returns:
;	0 if not a leap year
;	1 if a leap year


(setq OKLeap 0)

; Is year divisible by 4
(if (eq (rem Year 4.0) 0.0)
(setq OKLeap 1)
)

; but not dividible by 100,
(if (eq OKLeap 1)
 (if (and (eq (rem Year 100.0) 0.0) (not (eq (rem Year 400.0) 0.0)))
 	(setq OKLeap 0)
 )
)

;(if (not (eq (rem Year 4.0) 0.0))
;  (progn
;  	; Not divisible by 4, not a leap year
;  	(setq OKLeap 0)
;  )
;  (progn
;  	(if (not (eq (rem Year 100.0)))
;  	  (progn
;  	  	; Not divisible by 100, a leap year
;  	  	(setq OKLeap 1)
;  	  )	
;  	  (progn
;		(if (not (eq (rem Year 400.0)))
;		  (progn
;		  	; not divisible by 400, not a leap year
;		  	(setq OKLeap 0)
;		  )
;		  (progn
;		  	; otherwise, a leap year
;			(setq OKLeap 1)
;		  )
;		)
;	  )	
;	)	
;  )


OKLeap
)


;;---------------------=={ Internet Time }==------------------;;
;;                                                            ;;
;;  Returns the date and/or UTC time as a string in the       ;;
;;  format specified. Data is sourced from a NIST server.     ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  format - string specifying format of returned information ;;
;;           using the following identifiers to represent     ;;
;;           date & time quantities:                          ;;
;;           YYYY = 4-digit year                              ;;
;;           YY   = Year, MO = Month,   DD = Day              ;;
;;           HH   = Hour, MM = Minutes, SS = Seconds          ;;
;;------------------------------------------------------------;;
;;  Returns:  String containing formatted date/time data      ;;
;;------------------------------------------------------------;;
; All users should ensure that their software NEVER queries a server more frequently than once every 4 seconds.
; Systems that exceed this rate will be refused service.
; http://www.theswamp.org/index.php?topic=39491.msg447974#msg447974

(defun LM:InternetTime ( format / result rgx server xml )
   (setq server "http://time.nist.gov:13")
   (setq result
       (vl-catch-all-apply
           (function
               (lambda ( / str )
                   (setq xml (vlax-create-object "MSXML2.XMLHTTP.3.0"))
                   (setq rgx (vlax-create-object "VBScript.RegExp"))
                   (vlax-invoke-method xml 'open "POST" server :vlax-false)
                   (vlax-invoke-method xml 'send)
                   (if (setq str (vlax-get-property xml 'responsetext))
                       (progn
                           (vlax-put-property rgx 'global     actrue)
                           (vlax-put-property rgx 'ignorecase actrue)
                           (vlax-put-property rgx 'multiline  actrue)
                           (setq str (strcat " " (itoa (jtoy (+ (atoi (substr str 2 5)) 2400000.5))) (substr str 7)))
                           (mapcar
                               (function
                                   (lambda ( a b )
                                       (vlax-put-property rgx 'pattern a)
                                       (setq format (vlax-invoke rgx 'replace format b))
                                   )
                               )
                              '("YYYY" "YY" "MO" "DD" "HH" "MM" "SS")
                              '( "$1"  "$2" "$3" "$4" "$5" "$6" "$7")
                           )
                           (vlax-put-property rgx 'pattern
                               (strcat
                                   "(?:[^\\d]+)([\\d]+)(?:[^\\d]+)([\\d]+)"
                                   "(?:[^\\d]+)([\\d]+)(?:[^\\d]+)([\\d]+)"
                                   "(?:[^\\d]+)([\\d]+)(?:[^\\d]+)([\\d]+)"
                                   "(?:[^\\d]+)([\\d]+)(?:.+)\\n"
                               )
                           )
                           (vlax-invoke-method rgx 'replace str format)
                       )
                   )
               )
           )
       )
   )
   (if xml  (vlax-release-object xml))
   (if rgx  (vlax-release-object rgx))
   (if (not (vl-catch-all-error-p result))
       result
   )
)

;; Julian Date to Calendar Year - Lee Mac
;; Algorithm from: Meeus, Jean.  Astronomical Algorithms.
(defun jtoy ( j / a b c d )
   (setq j (fix j)
         a (fix (/ (- j 1867216.25) 36524.25))
         b (+ (- (+ j 1 a) (fix (/ a 4))) 1524)
         c (fix (/ (- b 122.1) 365.25))
         d (fix (/ (- b (fix (* 365.25 c))) 30.6001))
   )
   (fix (- c (if (< 2 (fix (if (< d 14) (1- d) (- d 13)))) 4716 4715)))
)

August 13, 2018

Please use attached code. I had added a bunch of comments and expanded the code for clarity, but had trouble posting and inadvertently posted work in progress that wasn't check for errors. Sorry about that...

TIMEBOMB.LSP

August 15, 2018

Thanks a lot kirby..

so i will insert my code in this line is it?

; Routine continues if not expired
(prompt "\n Program continues here...")

(princ)

August 15, 2018

Yes, add your code after the "; Routine continues if not expired" comment.

See modified version with following changes

- CheckProgramExpire has been modified to include the test date as input

- wraps the error trap 'setup' and 'cancel' into separate functions (or could build these into the 'CheckProgramExpire' routine, but this wouldn't give you the chance to add additional program-specific comments before you exit).

The updated example should make it easier to drop a generic block of code into an existing routine.

; Sample timebomb application - Verion 2
; KJM - Dec 2009, Mod Aug 2018
; Used to stop a routine from running if date has been exceeded

; Global variables
(setq ProgramExpiryDate "20180827")	; change this date before or after current date to test
(setq ProgramContact "Contact XYZZY for renewal at xyzzy@nospam.net or xxx.xxx.xxxx")
(setq *error* nil)
(setq OldErrorTrap nil)

; ------------------- Main Program

(defun C:Test1 ( / *error* )
; Test function for 'CheckProgramExpire' timebomb
; KJM - Dec 2009

; ------------------ Begin expiry date check

; Start error trap
(SetProgramExitErrorTrap)

; Check Expiry Date using custom function
(setq MyCode (CheckProgramExpire2 nil (atoi ProgramExpiryDate) ProgramContact))
;(prompt "\nReturned Code: ")(princ MyCode)
;(princ)

; Terminate routine if expired
(if (eq MyCode 0)
 (progn
 	(prompt "\n  ")
 	; add additional error messages here
 	(princ)
 	(exit)	
 )
)

; Cancel error trap, reset back to original
(CancelProgramExitErrorTrap)

; ------------------- End expiry date check

; Routine continues if not expired
(setq a (getstring 1 "\nEnter something..."))
(prompt "\n  You entered '")(princ a)(prompt "' ")

(princ)


)
(prompt "\nTest1 - test program Ver 1.")(princ)





; ------------------ Support functions

(defun SetProgramExitErrorTrap ( / msg)
; Specify special error trap to capture (exit)
; KJM - Aug 2018
; Input:
;	nothing
;
; Uses Global variables 'OldErrorTrap' and '*error*'
(setq OldErrorTrap *error*)
(defun *error*  (msg)
(if (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
  (progn
  	; add error message here
  	;(princ (strcat "\n  *** Error: " msg " **"))
  	(princ)
  )
)
(princ)
)
(princ)
)


(defun CancelProgramExitErrorTrap ()
; Cancel special error trap, reset to previous
; KJM - Aug 2018
(setq *error* OldErrorTrap)
(princ)
)







(defun CheckProgramExpire2  (TestDate ExpiryDate RenewString / CurrentDate OutCode)
; Expiration date check ver 2
; KJM - Dec 2009, based on code by Irne Barnard, Mod KJM Aug 2018
; http://forums.augi.com/showthread.php?80070-Code-help&p=842603&viewfull=1#post842603
; Input:
;	TestDate - (integer) format YYYYMODD, nil to use current data
;	ExpiryDate - (integer) format YYYYMODD
;	RenewString - (string) info for contact info on timer failure, nil to omit displaying renewal string
; Returns:
;	0 if failed
;	1 if passed
;	prints 'Program Expiry' message to command line
;
; Example Use:
; 	(setq MyCode (CheckProgramExpire2 nil (atoi MyTestDate) "Contact XYZZY for renewal at xyzzy@nospam.net or xxx.xxx.xxxx"))


(if (eq TestDate nil)
 (progn
; Add expiry data in YYYYMODD format and contact info message here
(setq TestDate (atoi (LM:InternetTime "YYYYMODD")))		; Mod KJM Jan 2012
;(setq TestDate (getvar "CDATE"))				; Orig version
 )
)

(if (> TestDate ExpiryDate)
 (progn
 	(prompt "\n  *** Program Expired ***")(princ)
 	(if RenewString
  (progn
  	(prompt (strcat "\n  " RenewString))
	(princ)
  )
)
(setq OutCode 0)
 )
 (progn
(princ (strcat "\n  *** Program active for " (itoa (fix (- ExpiryDate TestDate))) " more day(s) *** "))
(princ)
(setq OutCode 1)
 )
)

OutCode
)






;;---------------------=={ Internet Time }==------------------;;
;;                                                            ;;
;;  Returns the date and/or UTC time as a string in the       ;;
;;  format specified. Data is sourced from a NIST server.     ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  format - string specifying format of returned information ;;
;;           using the following identifiers to represent     ;;
;;           date & time quantities:                          ;;
;;           YYYY = 4-digit year                              ;;
;;           YY   = Year, MO = Month,   DD = Day              ;;
;;           HH   = Hour, MM = Minutes, SS = Seconds          ;;
;;------------------------------------------------------------;;
;;  Returns:  String containing formatted date/time data      ;;
;;------------------------------------------------------------;;
; All users should ensure that their software NEVER queries a server more frequently than once every 4 seconds.
; Systems that exceed this rate will be refused service.
; http://www.theswamp.org/index.php?topic=39491.msg447974#msg447974

(defun LM:InternetTime ( format / result rgx server xml )
   (setq server "http://time.nist.gov:13")
   (setq result
       (vl-catch-all-apply
           (function
               (lambda ( / str )
                   (setq xml (vlax-create-object "MSXML2.XMLHTTP.3.0"))
                   (setq rgx (vlax-create-object "VBScript.RegExp"))
                   (vlax-invoke-method xml 'open "POST" server :vlax-false)
                   (vlax-invoke-method xml 'send)
                   (if (setq str (vlax-get-property xml 'responsetext))
                       (progn
                           (vlax-put-property rgx 'global     actrue)
                           (vlax-put-property rgx 'ignorecase actrue)
                           (vlax-put-property rgx 'multiline  actrue)
                           (setq str (strcat " " (itoa (jtoy (+ (atoi (substr str 2 5)) 2400000.5))) (substr str 7)))
                           (mapcar
                               (function
                                   (lambda ( a b )
                                       (vlax-put-property rgx 'pattern a)
                                       (setq format (vlax-invoke rgx 'replace format b))
                                   )
                               )
                              '("YYYY" "YY" "MO" "DD" "HH" "MM" "SS")
                              '( "$1"  "$2" "$3" "$4" "$5" "$6" "$7")
                           )
                           (vlax-put-property rgx 'pattern
                               (strcat
                                   "(?:[^\\d]+)([\\d]+)(?:[^\\d]+)([\\d]+)"
                                   "(?:[^\\d]+)([\\d]+)(?:[^\\d]+)([\\d]+)"
                                   "(?:[^\\d]+)([\\d]+)(?:[^\\d]+)([\\d]+)"
                                   "(?:[^\\d]+)([\\d]+)(?:.+)\\n"
                               )
                           )
                           (vlax-invoke-method rgx 'replace str format)
                       )
                   )
               )
           )
       )
   )
   (if xml  (vlax-release-object xml))
   (if rgx  (vlax-release-object rgx))
   (if (not (vl-catch-all-error-p result))
       result
   )
)

;; Julian Date to Calendar Year - Lee Mac
;; Algorithm from: Meeus, Jean.  Astronomical Algorithms.
(defun jtoy ( j / a b c d )
   (setq j (fix j)
         a (fix (/ (- j 1867216.25) 36524.25))
         b (+ (- (+ j 1 a) (fix (/ a 4))) 1524)
         c (fix (/ (- b 122.1) 365.25))
         d (fix (/ (- b (fix (* 365.25 c))) 30.6001))
   )
   (fix (- c (if (< 2 (fix (if (< d 14) (1- d) (- d 13)))) 4716 4715)))
)

August 17, 2018

Noted. Thanks a lot kirby

August 17, 2018

You just need 1 line in each piece of code you want checked you would make the check a program that gets loaded every time at the start of code, it would be wise to make all code to FAS. Just load your timebomb and check. I was involved in a big software suite that had multiple modules rather than 1 big code, so easy to have check as 1st couple of lines.

(load "timebomb")
rest of your code
........

August 17, 2018

but if i give the fas file to someone else the Timebomb lisp won't load...

August 17, 2018

.. you can make AutoCAD speak? You realise I am not going to be at all popular next week.

Autoload a LISP, It says "Not another drawing", for every drawing you open

I'm going to enjoy this.

August 17, 2018

Cad_Noob

Alternate to multiple .FAS files could be a .VLX (Windows only). .VLX can include several separate program files (.lsp or .fas), resources, etc. all compiled into one .VLX file.

I typically just load separate .LSP (or .FAS) with library routines as needed, but I don't sell anything so am not worried about protection, etc. When delivering a smaller, limited scope solutions to others/customers, it's often easiest to add all your referenced functions into a single .LSP then compiling into .FAS. Then archive your source and .FAS, or use poor man's change tracking via filename (eg. MyProgram-2018-08-17.fas , MyProgramVer1.1.fas) so that you can keep track of updates.

Also note that if you want to use the example program I provided as-is, you will need to speak to Lee Mac about using his copyrighted internet time function or use something else (e.g. benhubel's 'time travelling' suggestion earlier in this thread).

August 17, 2018

The timebomb should work I dont need fas at moment but will check you can load multiple lisps into a running lisp no problems and as the time bomb check is 1st line its checked, thing is you can write code and test and just have your timebomb.lsp date set to not expire etc.

; example of calling a library dcl in any program
(if (not AH:getvals)(load "getvals.fas"))
(ah:getvals "titel 1" 5 4 "default)
; do something value returned
.... your code now

February 17, 2019

On 8/10/2018 at 11:21 PM, kirby said:

Cad_Noob

Please see sample timebomb application that I was playing with a few years ago after seeing a few posts on the subject. It is based on an idea posted by Irne Barnard, and uses an internet date check developed by Lee Mac to beat the 'reset PC clock' problem as an alternate to what BigAl has posted.

The routine has a sample internal error handler, and includes some other subroutines for checking the date (as well as date entry).

Run 'TestTimeBomb' to demonstrate, and test using a few different dates to test against.


; Sample timebomb application
; KJM - Dec 2009
; Used to stop a routine from running if date has been exceeded


(defun C:TestTimeBomb ( / *error* )
; Test function for 'CheckProgramExpire' timebomb
; KJM - Dec 2009

; Specify special error trap for this routine
(setq OldErrorTrap *error*)
(defun *error*  (msg)
(if (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
  (progn
  	; add final error message here
  	(princ (strcat "\n*** Error: " msg " **"))
  	(princ)
  )
)
(princ)
)


; Get a data
(setq MyTestDate (getdatestring nil nil))
(prompt "\n  Date entered = ")(princ MyTestDate)(princ)

; Add expiry data in YYYYMODD format and contact info message here
(setq MyCode (CheckProgramExpire (atoi MyTestDate) "Contact XYZZY for renewal at xyzzy@nospam.net or xxx.xxx.xxxx"))
;(prompt "\nReturned Code: ")(princ MyCode)
;(princ)

; Terminate routine if expired
(if (eq MyCode 0)
 (progn
 	(prompt "\n")
 	; add additional error messages here
 	(princ)
 	(exit)	
 )
)

; Routine continues if not expired
(prompt "\nProgram continues here...")
(princ)

; Remove special error trap, restore original
(setq *error* OldErrorTrap)

)
(prompt "\nTestTimeBomb - test time bomb routine to stop program execution.")(princ)




(defun CheckProgramExpire (ExpiryDate RenewString / CurrentDate OutCode)
; Expiration date
; KJM - Dec 2009, based on code by Irne Barnard
; http://forums.augi.com/showthread.php?80070-Code-help&p=842603&viewfull=1#post842603
; Input:
;	ExpiryDate - (integer) format YYYYMODD
;	RenewString - (string) info for contact info on timer failure (nil to omit)
; Returns:
;	0 if failed
;	1 if passed
;	prints 'Program Expiry' message to command line

(setq CurrentDate (atoi (LM:InternetTime "YYYYMODD")))		; Mod KJM Jan 2012
;(setq CurrentDate (getvar "CDATE"))				; Orig version

(prompt "Checking date ... ")(princ)

(if (> CurrentDate ExpiryDate)
 (progn
 	(prompt "\n*** Program Expired ***")(princ)
 	(if RenewString
  (progn
  	(prompt (strcat "\n" RenewString))
	(princ)
  )
)
(setq OutCode 0)
 )
 (progn
(princ (strcat "\n*** Program active for " (itoa (fix (- ExpiryDate CurrentDate))) " more day(s) *** "))
(princ)
(setq OutCode 1)
 )
)

OutCode
)




(defun GetDateString (MyPrompt Default / Data)
; Get Date as a "YYYYMMDD" string and validate
; KJM - Sept 1991
; Input:
;	DataPrompt - (string) prompt, is nil use default "Enter date in YYYYMMDD format"
;	Default - default value, if nil use (rtos (getvar "cdate") 2 0) to supply current date
; Returns:
;	string in "YYYYMMDD" format



; Use default prompt if none provided
(if (eq MyPrompt nil)
(setq MyPrompt "Enter data in YYYYMMDD format")
)

; Use current date if none provided
(if (eq Default nil)
(setq Default (substr (rtos (getvar "cdate") 2 0) 1 )
)	

(setq k 1)
(while k
(prompt (strcat "\n" MyPrompt " <"))
(princ Default)(princ)

(setq Data (getstring ">: "))
(if (= Data "")
  (progn
	; Use default date, stop loop
	(setq Data Default setq k nil)
  )
  (progn
	; Validate date (8 characters + all numeric)
	(if (and (eq (strlen Data)  (numberp (atoi Data)))
	  (progn
		(setq OKYear 0 OKMonth 0 OKDay 0)		; default to incorrect
	
		(setq MyYear (atoi (substr Data 1 4)))
		(setq LeapYear (IsLeapYear MyYear))		; check if year is leap year using custom function
		(setq MyMonth (atoi (substr Data 5 2)))
		(setq MyDay (atoi (substr Data 7 2)))
		
		; Check year (adjust year limits as required)
		(if (and (>= MyYear 1900) (<= MyYear 2101))
			(setq OKYear 1)
		)
		
		; Check month between 1 and 12
		(if (and (>= MyMonth 1) (<= MyMonth 12))
			(setq OKMonth 1)
		)
		
		; Check day
		(setq DaysInMonthList (list 31 28 31 30 31 30 31 31 30 31 30 31))
		
		(if (and (eq MyMonth 2) (eq IsLeapYear 1))
		  (progn
			; Leap year check for February
			(if (and (>= MyDay 1) (<= MyDay 29))
				(setq OKDay 1)
			)	
		  )
		  (progn
		  	; Not a leap year
		  	(if (and (>= MyDay 1) (<= MyDay (nth (1- MyMonth) DaysInMonthList)))
		  		(setq OKDay)
			)
		  )
		)
		
		; Validated!
		(if (and (eq OKYear 1) (eq OKMonth 1) (eq OKDay 1))
	  		(setq k nil)	; stop loop
		)
	
	  )
	)	
  )
)
) ; close while	

Data
)


(defun IsLeapYear (Year / )
; Test for leap year, may not be valid pre 1600?
; KJM - Jan 1989
; Input:
;	Year = (integer) repesenting the year to check
; Returns:
;	0 if not a leap year
;	1 if a leap year


(setq OKLeap 0)

; Is year divisible by 4
(if (eq (rem Year 4.0) 0.0)
(setq OKLeap 1)
)

; but not dividible by 100,
(if (eq OKLeap 1)
 (if (and (eq (rem Year 100.0) 0.0) (not (eq (rem Year 400.0) 0.0)))
 	(setq OKLeap 0)
 )
)

;(if (not (eq (rem Year 4.0) 0.0))
;  (progn
;  	; Not divisible by 4, not a leap year
;  	(setq OKLeap 0)
;  )
;  (progn
;  	(if (not (eq (rem Year 100.0)))
;  	  (progn
;  	  	; Not divisible by 100, a leap year
;  	  	(setq OKLeap 1)
;  	  )	
;  	  (progn
;		(if (not (eq (rem Year 400.0)))
;		  (progn
;		  	; not divisible by 400, not a leap year
;		  	(setq OKLeap 0)
;		  )
;		  (progn
;		  	; otherwise, a leap year
;			(setq OKLeap 1)
;		  )
;		)
;	  )	
;	)	
;  )


OKLeap
)


;;---------------------=={ Internet Time }==------------------;;
;;                                                            ;;
;;  Returns the date and/or UTC time as a string in the       ;;
;;  format specified. Data is sourced from a NIST server.     ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  format - string specifying format of returned information ;;
;;           using the following identifiers to represent     ;;
;;           date & time quantities:                          ;;
;;           YYYY = 4-digit year                              ;;
;;           YY   = Year, MO = Month,   DD = Day              ;;
;;           HH   = Hour, MM = Minutes, SS = Seconds          ;;
;;------------------------------------------------------------;;
;;  Returns:  String containing formatted date/time data      ;;
;;------------------------------------------------------------;;
; All users should ensure that their software NEVER queries a server more frequently than once every 4 seconds.
; Systems that exceed this rate will be refused service.
; http://www.theswamp.org/index.php?topic=39491.msg447974#msg447974

(defun LM:InternetTime ( format / result rgx server xml )
   (setq server "http://time.nist.gov:13")
   (setq result
       (vl-catch-all-apply
           (function
               (lambda ( / str )
                   (setq xml (vlax-create-object "MSXML2.XMLHTTP.3.0"))
                   (setq rgx (vlax-create-object "VBScript.RegExp"))
                   (vlax-invoke-method xml 'open "POST" server :vlax-false)
                   (vlax-invoke-method xml 'send)
                   (if (setq str (vlax-get-property xml 'responsetext))
                       (progn
                           (vlax-put-property rgx 'global     actrue)
                           (vlax-put-property rgx 'ignorecase actrue)
                           (vlax-put-property rgx 'multiline  actrue)
                           (setq str (strcat " " (itoa (jtoy (+ (atoi (substr str 2 5)) 2400000.5))) (substr str 7)))
                           (mapcar
                               (function
                                   (lambda ( a b )
                                       (vlax-put-property rgx 'pattern a)
                                       (setq format (vlax-invoke rgx 'replace format b))
                                   )
                               )
                              '("YYYY" "YY" "MO" "DD" "HH" "MM" "SS")
                              '( "$1"  "$2" "$3" "$4" "$5" "$6" "$7")
                           )
                           (vlax-put-property rgx 'pattern
                               (strcat
                                   "(?:[^\\d]+)([\\d]+)(?:[^\\d]+)([\\d]+)"
                                   "(?:[^\\d]+)([\\d]+)(?:[^\\d]+)([\\d]+)"
                                   "(?:[^\\d]+)([\\d]+)(?:[^\\d]+)([\\d]+)"
                                   "(?:[^\\d]+)([\\d]+)(?:.+)\\n"
                               )
                           )
                           (vlax-invoke-method rgx 'replace str format)
                       )
                   )
               )
           )
       )
   )
   (if xml  (vlax-release-object xml))
   (if rgx  (vlax-release-object rgx))
   (if (not (vl-catch-all-error-p result))
       result
   )
)

;; Julian Date to Calendar Year - Lee Mac
;; Algorithm from: Meeus, Jean.  Astronomical Algorithms.
(defun jtoy ( j / a b c d )
   (setq j (fix j)
         a (fix (/ (- j 1867216.25) 36524.25))
         b (+ (- (+ j 1 a) (fix (/ a 4))) 1524)
         c (fix (/ (- b 122.1) 365.25))
         d (fix (/ (- b (fix (* 365.25 c))) 30.6001))
   )
   (fix (- c (if (< 2 (fix (if (< d 14) (1- d) (- d 13)))) 4716 4715)))
)

Hello,

I have tested your code and the timebomb works, although I tried to add a code, and after calling test1, it displays "enter something" and it doesnt recognize the code command

Edit 1: i have found a solution on my own way!!,

interesting code. is it easy to crack?

Edited February 17, 2019 by Dani_Nadir
solution found

February 17, 2019

On 1/6/2018 at 3:09 AM, BIGAL said:
Like Kirby you would do some form of elaborate message before the (exit)

For a laugh just wait for sound, I will find better version.
(defun SpeakSapi ( s / sapi )
(if (eq (type s) 'STR) 
(progn 
(setq sapi (vlax-create-object "Sapi.SpVoice"))
(vlax-put sapi 'SynchronousSpeakTimeout 1)
(vlax-invoke-method sapi 'WaitUntilDone 0)
(vlax-invoke sapi "Speak" s 0)
(vlax-release-object sapi)
)))
(speaksapi "Welcome from BIG al the humour and respect you can expect here at Cad tutor")
(speaksapi "PLEASE PAY YOUR MONEY")
(speaksapi "I know you have wound the clock back" )
(speaksapi "Call me on 1234 5678 if you like the software")
Hello BIGAL,

It's a nice code for joking. I tested it but I have to wait too much time in order to listen to the voice.

December 17, 2021

On 8/8/2018 at 6:04 AM, BIGAL said:

Time bound Lisp

Recommended Posts

BIGAL

Link to comment

Share on other sites

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

Steven P

mhupp

BIGAL

CAD_Noob

Link to comment

Share on other sites

kirby

Link to comment

Share on other sites

kirby

Link to comment

Share on other sites

CAD_Noob

Link to comment

Share on other sites

kirby

Link to comment

Share on other sites

CAD_Noob

Link to comment

Share on other sites

BIGAL

Link to comment

Share on other sites

CAD_Noob

Link to comment

Share on other sites

Steven P

Link to comment

Share on other sites

kirby

Link to comment

Share on other sites

BIGAL

Link to comment

Share on other sites

Dani_Nadir

Link to comment

Share on other sites

Dani_Nadir

Link to comment

Share on other sites

robierzo

Link to comment

Share on other sites

Steven P

Link to comment

Share on other sites

robierzo

Link to comment

Share on other sites

Steven P

Link to comment

Share on other sites

mhupp

Link to comment

Share on other sites

robierzo

Link to comment

Share on other sites

Join the conversation

Tutorials

Forums

Activity