fork(1) download
copy 
  1. ; square triple
  2.  
  3. (define range
  4.   (case-lambda
  5.     ((stop) (range 0 stop (if (negative? stop) -1 1)))
  6.     ((start stop) (range start stop (if (< start stop) 1 -1)))
  7.     ((start stop step)
  8.       (let ((le? (if (negative? step) >= <=)))
  9.         (let loop ((x start) (xs (list)))
  10.           (if (le? stop x) (reverse xs)
  11.             (loop (+ x step) (cons x xs))))))
  12.     (else (error 'range "too many arguments"))))
  13.  
  14. (define-syntax fold-of
  15.   (syntax-rules (range in is)
  16.     ((_ "z" f b e) (set! b (f b e)))
  17.     ((_ "z" f b e (v range fst pst stp) c ...)
  18.       (let* ((x fst) (p pst) (s stp)
  19.              (le? (if (positive? s) <= >=)))
  20.         (do ((v x (+ v s))) ((le? p v) b)
  21.           (fold-of "z" f b e c ...))))
  22.     ((_ "z" f b e (v range fst pst) c ...)
  23.       (let* ((x fst) (p pst) (s (if (< x p) 1 -1)))
  24.         (fold-of "z" f b e (v range x p s) c ...)))
  25.     ((_ "z" f b e (v range pst) c ...)
  26.       (fold-of "z" f b e (v range 0 pst) c ...))
  27.     ((_ "z" f b e (x in xs) c ...)
  28.       (do ((t xs (cdr t))) ((null? t) b)
  29.         (let ((x (car t)))
  30.           (fold-of "z" f b e c ...))))
  31.     ((_ "z" f b e (x is y) c ...)
  32.       (let ((x y)) (fold-of "z" f b e c ...)))
  33.     ((_ "z" f b e p? c ...)
  34.       (if p? (fold-of "z" f b e c ...)))
  35.     ((_ f i e c ...)
  36.       (let ((b i)) (fold-of "z" f b e c ...)))))
  37.  
  38. (define-syntax list-of (syntax-rules ()
  39.   ((_ arg ...) (reverse (fold-of
  40.     (lambda (d a) (cons a d)) '() arg ...)))))
  41.  
  42. (define (isqrt n)
  43.   (if (not (and (positive? n) (integer? n)))
  44.       (error 'isqrt "must be positive integer")
  45.       (let loop ((x n))
  46.         (let ((y (quotient (+ x (quotient n x)) 2)))
  47.           (if (< y x) (loop y) x)))))
  48.  
  49. (define (f xs)
  50.   (list-of (list x y z)
  51.     (x in xs)
  52.     (y in xs)
  53.     (< x y)
  54.     (z2 is (* x y))
  55.     (z is (isqrt z2))
  56.     (= (* z z) z2)
  57.     (member z xs)))
  58.  
  59. (display (f (range 1 20))) (newline)
Success #stdin #stdout 0.01s 8656KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
((1 4 2) (1 9 3) (1 16 4) (2 8 4) (2 18 6) (3 12 6) (4 9 6) (4 16 8) (8 18 12) (9 16 12))
https://ideone.com/L7itmh
language:
Scheme (chicken 4.13)
created:
4 years ago
visibility:
secret

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!