fork download
copy 
  1. ; karate chop
  2.  
  3. (define-syntax while
  4.   (syntax-rules ()
  5.     ((while pred? body ...)
  6.       (do () ((not pred?)) body ...))))
  7.  
  8. (define-syntax assert
  9.   (syntax-rules ()
  10.     ((assert expr result)
  11.       (if (not (equal? expr result))
  12.           (for-each display `(
  13.             #\newline "failed assertion:" #\newline
  14.             expr #\newline "expected: " ,result
  15.             #\newline "returned: " ,expr #\newline))))))
  16.  
  17. (define (test chop)
  18.   (assert (chop 3 '#()) -1)
  19.   (assert (chop 3 '#(1)) -1)
  20.   (assert (chop 3 '#(3)) 0)
  21.   (assert (chop 1 '#(1 3 5)) 0)
  22.   (assert (chop 3 '#(1 3 5)) 1)
  23.   (assert (chop 5 '#(1 3 5)) 2)
  24.   (assert (chop 0 '#(1 3 5)) -1)
  25.   (assert (chop 2 '#(1 3 5)) -1)
  26.   (assert (chop 4 '#(1 3 5)) -1)
  27.   (assert (chop 6 '#(1 3 5)) -1)
  28.   (assert (chop 1 '#(1 3 5 7)) 0)
  29.   (assert (chop 3 '#(1 3 5 7)) 1)
  30.   (assert (chop 5 '#(1 3 5 7)) 2)
  31.   (assert (chop 7 '#(1 3 5 7)) 3)
  32.   (assert (chop 0 '#(1 3 5 7)) -1)
  33.   (assert (chop 2 '#(1 3 5 7)) -1)
  34.   (assert (chop 4 '#(1 3 5 7)) -1)
  35.   (assert (chop 6 '#(1 3 5 7)) -1)
  36.   (assert (chop 8 '#(1 3 5 7)) -1))
  37.  
  38. (define (chop1 needle haystack)
  39.   (call-with-current-continuation
  40.     (lambda (return)
  41.       (let ((lo 0) (hi (- (vector-length haystack) 1)))
  42.         (while (<= lo hi)
  43.           (let ((mid (quotient (+ lo hi) 2)))
  44.             (cond ((< needle (vector-ref haystack mid))
  45.                     (set! hi (- mid 1)))
  46.                   ((< (vector-ref haystack mid) needle)
  47.                     (set! lo (+ mid 1)))
  48.                   (else (return mid)))))
  49.         (return -1)))))
  50.  
  51. (test chop1)
  52.  
  53. (define (chop2 needle haystack)
  54.   (chop2-aux needle haystack 0 (- (vector-length haystack) 1)))
  55.  
  56. (define (chop2-aux needle haystack lo hi)
  57.   (call-with-current-continuation
  58.     (lambda (return)
  59.       (if (< hi lo) (return -1)
  60.         (let ((mid (quotient (+ lo hi) 2)))
  61.           (cond ((< needle (vector-ref haystack mid))
  62.                   (return (chop2-aux needle haystack lo (- mid 1))))
  63.                 ((< (vector-ref haystack mid) needle)
  64.                   (return (chop2-aux needle haystack (+ mid 1) hi)))
  65.                 (else (return mid))))))))
  66.  
  67. (test chop2)
  68.  
  69. (define (chop3 needle haystack)
  70.   (let loop ((lo 0) (hi (- (vector-length haystack) 1)))
  71.     (if (< hi lo) -1
  72.       (let ((mid (quotient (+ lo hi) 2)))
  73.         (cond ((< needle (vector-ref haystack mid))
  74.                 (loop lo (- mid 1)))
  75.               ((< (vector-ref haystack mid) needle)
  76.                 (loop (+ mid 1) hi))
  77.               (else mid))))))
  78.  
  79. (test chop3)
  80.  
  81. (define (chop4 needle haystack)
  82.   (call-with-current-continuation
  83.     (lambda (return)
  84.       (let ((lo 0) (hi (- (vector-length haystack) 1)))
  85.         (while (< lo hi)
  86.           (let ((mid (quotient (+ lo hi) 2)))
  87.             (if (< (vector-ref haystack mid) needle)
  88.                 (set! lo (+ mid 1))
  89.                 (set! hi mid))))
  90.         (if (and (= lo hi) (= needle (vector-ref haystack lo)))
  91.             (return lo)
  92.             (return -1))))))
  93.  
  94. (test chop4)
  95.  
  96. (define (chop5 needle haystack)
  97.   (let loop ((lo 0) (hi (- (vector-length haystack) 1)))
  98.     (if (<= hi lo)
  99.         (if (and (= lo hi) (= needle (vector-ref haystack lo))) lo -1)
  100.         (let ((mid (quotient (+ lo hi) 2)))
  101.           (if (< (vector-ref haystack mid) needle)
  102.               (loop (+ mid 1) hi)
  103.               (loop lo mid))))))
  104.  
  105. (test chop5)
Success #stdin #stdout 0.01s 8044KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 

	

		
	 
	
	
			

					
			
			
			
			
			
			
			
			

			
			
			
		

	
		
		

			

			                        







			
			

				

	
					
					 https://ideone.com/BxXfot
					
					
					
					
					

												

												
						
						

					

					
					
					

						
language:

						
 ()

					

					

						
created:
								
						
8 years ago

					

					

						
visibility:

						

							 public																												
							
							

								
							

						

					

										
										

					
					 Share or Embed source code
					
					
					
					

						
						
						
						
						
						
						
					

					
						
	
	
	
	
					
					
					
					
					 
					
					
					
					 
					
					
					
					
					
					

					

					

					
						
					

					


	
Discover > Sphere Engine API

	
The brand new service which powers Ideone!

	
	
Discover > IDE Widget

    
Widget for compiling and running the source code in a web browser!