[-*- Mode: lispcc -*-]
[(setq ss-verify-run nil)]

























[-----grammar
 (gz start (prog))
 (gz prog (module))
 (gz module (f :class id exports imports :cbeg f topdecl-star j j
             ::pr("module [[id]] [[exports]] where{\n[[imports]]\n"
                  "[[topdecl-star('',';\n','\n')]]}\n\n")))
 (gz exports (f export-star j
              ::pr("[[export-star('(',',',')')]]")) (:export-everything ::pr("")))
 (gz export (id))
 (gz imports (f import-star j
              ::pr("[[import-star('',';\n',';\n')]]")))
 (gz import(id ::pr( "import [[id]]")))
 (gz type-class (f :type-class context-opt type f type-class-decl-star j j
                 ::pr("class [[context-opt]][[type]] where{\n"
                      "[[type-class-decl-star('',';\n','\n')]]}")))
 (gz topdecl (decl) (data)(type-synonym)(newtype)(instance)(type-class))
 (gz type-class-decl (type-signature)(decl))
 (gz type-signature (f :tysig name ret-type-and-params j
                     ::pr("[[name]]::[[ret-type-and-params]]")))
 (gz instance (f :instance (type ::is id) (name ::is simpletype)  decls j
               ::pr ("instance [[type]] ([[name]]) where [[decls]]")))
 [(gz instance (f :instance context-opt (type ::is id) simpletype-plus :x decls j
                ::pr ("instance [[context-opt]][[type]] [[simpletype-plus('(',')(',')')]] where [[decls]]")))]
 (gz newtype (f :newtype simpletype type deriving-opt j
              ::pr("newtype [[simpletype]] = [[type]][[deriving-opt]]")))
 (gz deriving (:deriving f id-non-plus j
               ::pr(" deriving [[id-non-plus('(',',',')')]]")))
 (gz id-non (id))
 (gz type-synonym (f :type-synonym simpletype type j
                   ::pr("type [[simpletype]] = [[type]]")))
 (gz data (f :data simpletype constrs deriving-opt j ::pr("data [[simpletype]] = [[constrs]][[deriving-opt]]")))
 (gz simpletype (f id-non-plus j ::pr ("[[id-non-plus('',' ','')]]")))
 (gz constrs(f constr-star j ::pr("[[constr-star('',' | ','')]]"))

  )
 (gz field-type-and-param (f param type j
                           ::pr("[[param]]::[[type]]")))
 (gz type-and-param ( f param type j ::pr("[[type]]")))
 (gz constr(positional-constructor) (field-label-constructor) )
 (gz field-label-constructor(f type-ctor :field f field-type-and-param-star j j
                             ::pr("[[type-ctor]][[field-type-and-param-star('{',',','}')]]")))

 (gz decls (  decl-star  ::pr("{[[decl-star('\n',';\n','\n')]]}\n")))
 (gz context (:context f a-context-plus j ::pr
              ("[[a-context-plus('(',',',')')]]=>")))
 (gz a-context (f (type ::is id)(name ::is id) j ::pr("[[type]] [[name]]")))
 (gz ret-type-and-params
  (context-opt type f type-and-param-star j
   ::pr("[[context-opt]][[type-and-param-star('','\x2d>','')]]"
        (::c "if(my_type_and_param_star->v.size()>0)out('\x2d>');")
        "[[type]]")))

 (gz decl (f :fun name ret-type-and-params  expr j
           ::pr("[[name]]::[[ret-type-and-params]];\n"
                "[[name]]"
                (::c "for(many_trees::const_iterator pos = my_ret_type_and_params->my_type_and_param_star->v.begin();pos!= my_ret_type_and_params->my_type_and_param_star->v.end();++pos){"
                 "const tr_type_and_param* t=dynamic_cast<const tr_type_and_param*>(*pos);"
                 "assert(t);"
                 "out(' ');"
                 "t->my_param->print();" "}")
                " = [[expr]]"))
  (f :fun name :no-sig ret-type-and-params  expr j
   ::pr("[[name]]"
        (::c "for(many_trees::const_iterator pos = my_ret_type_and_params->my_type_and_param_star->v.begin();pos!= my_ret_type_and_params->my_type_and_param_star->v.end();++pos){"
         "const tr_type_and_param* t=dynamic_cast<const tr_type_and_param*>(*pos);"
         "assert(t);"
         "out(' ');"
         "t->my_param->print();" "}")
        " = [[expr]]")))
 (gz name (id))
 (gz positional-constructor
  (f   type-ctor typepls-opt j
   ::pr("[[type-ctor]][[typepls-opt]]"))
  (f :tuple type-plus j
   ::pr("[[type-plus('(',',',')')]]"))
  )
 (gz pattern
  (f  pattern-ctor pattern-star j
   ::pr ("([[pattern-ctor]][[pattern-star('',' ','')]])"))
  
  (f pattern-ctor :fpat f fpat-star j j
   ::pr ("[[pattern-ctor]][[fpat-star('{',',','}')]]"))
   
  (f :ptuple pattern-plus j [pattern-plus cuz :nil exists for empty lists]
   ::pr("[[pattern-plus('(',',',')')]]"))
  
  (f :plist pattern-plus j [pattern-plus cuz :nil exists for empty lists]
   ::pr("[[pattern-plus('\x5b',',','\x5d')]]"))
  
  (f :pchar astring j ::pr("(\x27[[astring]]\x27)"))

  (f :pstring astring j ::pr("\x22[[astring]]\x22"))
  
  (f :as id pattern j ::pr("[[id]]@[[pattern]]"))
  )
 (gz pattern-ctor (id) (:cons ::pr ("(:)")) (:nil ::pr ("[]")))

 (gz fpat (f (variable ::is id) pattern j
           ::pr("[[variable]] = [[pattern]]")))

 (gz type
  (f :fn ret-type-and-params j ::pr ("([[ret-type-and-params]])")) (:unit ::pr("()"))
  (positional-constructor))
 (gz typepls (paren-type-plus))
 (gz paren-type (type ::pr( "([[type]])"))
  (f :strict type j ::pr("!([[type]])"))
  (f :generic id j ::pr (" [[id]] ")))
 (gz type-ctor(id)(:list ::pr ("[]"))(:nondet ::pr ("[]")))
 (gz param (id))
 (gz qastring  (astring ::pr("\x22[[astring]]\x22")))

 (gz expr (id) (:mcons ::pr ("(:)")) [(:nil ::pr ("[]"))]
  (f :pipe expr-star j ::pr[("[[expr-star('(',' $ ',')')]]")]
   (
    (::c "for(many_trees::const_iterator pos = my_expr_star->v.begin();"
     "pos!=my_expr_star->v.end();++pos){")
    "("
    (::c "(*pos)->print();" "}")
    (::c "for(many_trees::const_iterator pos = my_expr_star->v.begin();"
     "pos!=my_expr_star->v.end();++pos){")
    ")"
    (::c  "}")
    )
   )
  (f :cc expr-star j ::pr ("[[expr-star('(',' ++ ',')')]]"))
  (qastring)
  (f :lit astring j ::pr("[[astring]]"))
  
  (f :ty type expr j ::pr("([[expr]]::[[type]])"))
  (f (fun-name ::is expr) expr-star j
   ::pr ("([[fun-name]][[expr-star(' ',' ','')]])"))
  [(f :construct ctor expr-star j
    ::pr ("([[ctor]] [[expr-star('',' ','')]])"))]
  (f :do  stmt-star  j ::pr("(do{\n[[stmt-star('  ','\n  ','\n')]]})"))
  (f :case expr  alt-star  j
   ::pr("(case [[expr]] of {\n[[alt-star('  ',';\n  ','\n')]]})"))
  
  (f :where expr decl-star j
   ::pr("(let {[[decl-star('\n',';\n','\n')]]}\n in [[expr]])"))
  (f :cfd (type ::is id) assignments-star j
   ::pr("[[type]][[assignments-star('{',',','}')]]"))
  [(f :compose (a ::is expr) (b ::is expr) j ::pr("((.)[[a]] [[b]])"))]
  [(:compose ::pr ("(.)"))]
  (f :compose expr-plus j ::pr ("[[expr-plus('(',' . ',')')]]"))
  (f :mlist expr-star j ::pr("[[expr-star('\x5b',',','\x5d')]]"))
  (f :cons-list expr-star j ::pr("[[expr-star('(',':',')')]]"))
  (f :mtuple expr-star j ::pr("[[expr-star('(',',',')')]]"))
  (:nothing  ::pr ("()"))

  )
 (gz assignments (f id expr j ::pr("[[id]] = [[expr]]")))
 (gz stmt (expr ::pr("[[expr]];"))
  (f ":=" id expr j ::pr("[[id]]<-[[expr]];")))
 (gz alt (f  pattern expr j
          ::pr("[[pattern]]\x2d>[[expr]]")))
 ]


(:class Main :export-everything
 ( Control.Exception Ratio IO System.IO.Unsafe  List  Monad Array
  [Data.FiniteMap Data.Set]
  System )
 :cbeg
 (
  (:fun show-list :context ((Show a))(String)((l(:list(a))))
   (unlines (map show l))
   )
  
  (:fun quiet(Bool)()True)

  (:fun cerr(a)((message (:list(String)))(x(a)))
   (:case quiet
    ((True)x)
    ((_)(unsafePerformIO
         (:do
          (hPutStrLn stderr (concat message))
          (return x))))))
  
  (:fun cerr-x(a)((_(:list(String)))(x(a)))x)

  (:fun peek :context((Show a))(a)((x(a)))
   (seq x (cerr (:mlist(show x)) x)))

  
  (:fun peek-more(a)((f(:fn(:list(String))((x(a)))))(x(a)))
   (:case quiet
    ((True)x)
    ((_)(seq x (cerr  (f x) x)))))
  (:fun peek-more-x(a)((_(:fn(:list(String))((x(a)))))(x(a)))x)

  (:fun zip-map(:list(:tuple(a)(b)))
   ((f(:fn(b)((x(a)))))(l(:list(a))))
   (zip l (map f l)))
  (:fun show-and :context ((Show a)(Show b))
   (IO :unit)((f(:fn(b)((x(a)))))(l(:list(a))))
   (:pipe putStr show-list (zip-map f l)))

  (:fun ntakes(:list(:list(a)))((n(Int))(l(:list(a))))
    (:mcons(take n l)(ntakes n (tail l)))
    )

  (:fun zero-to(:list(Int))((n(Int)))
    (take n (enumFrom 0)))

  (:fun enum-from-by :context((Num a)) (:list(a))((x(a))(delta(a)))
	(:mcons x (enum-from-by (+ x delta) delta)))
  
  (:fun rcs-code(String)()
   "$Id: primes-2.ll,v 1.313 2006/10/29 22:12:28 kenta Exp $")

  (:fun n-log-n(Int)((n(Int)))
    (floor (* (fromIntegral n) (log (fromIntegral n)))))
  (:fun is-prime(Bool)((x(Integer)))
   (:case (compare x 2)
    ((LT)False)
    ((EQ)True)
    ((GT)(:case (mod x 2)
          ((0)False)
          ((_)(miller-rabin x miller-rabin-bases))))
    ))
  (:fun miller-rabin-bases(:list(Integer))()(take 20 primes))
  (:fun miller-rabin(Bool)((n(Integer))(bases(:list(Integer))))
   (and (map (miller-rabin-1 n)
         bases
         )))
  
  (:fun miller-rabin-1(Bool)((n(Integer))(a(Integer)))
   (:pipe
    (assert (< 2 n))
    (assert (== 1 (mod n 2)))
    (:case (compare a (- n 1))
     ((LT)
      (:case(pow-2-special a (- n 1) n)
       ((Probable-prime)True)
       ((Composite)False)
       ((N(1))True)
       ((_)False))
      )
     ((_)True)
     )))
  
  (:fun pow-2-special(Miller-rabin-result)
   ((a(Integer))(n(Integer))(modulo-p(Integer)))
   (:where
    (peek-more end-show
     (:case (mod n 2)
      ((0)(:where
           (:case result
            ((N(b))(:case (classify b modulo-p)
                    ((Negative-unity)Probable-prime)
                    ((Unity)
                     (cerr
                      (:mlist
                       "nontrivial sqrt of unity "(show (div n 2)))
                      Composite))
                    ((Number)
                     [(N (modular-square b modulo-p))]
                     result
                     )))
            ((_)result)
            )
           (:fun result(Miller-rabin-result)()
            (modular-square-miller-rabin
             (pow-2-special a (div n 2) modulo-p)
             modulo-p
             ))
           ))
      ((_) (:where
            (:case (classify result modulo-p)
             ((Negative-unity)Probable-prime)
             ((Unity)Probable-prime)
             ((Number)(N result)))
            (:fun result(Integer)()
             (modular-exponentiation a n modulo-p))
            ))
      ))
    (:fun end-show(:list(String))((x(Miller-rabin-result)))
     (:mlist
      "pow-2-special "(show a)" "(show n)" "(show x)))
    ))
  
  (:data (Miller-rabin-result)((Probable-prime)(Composite)(N(Integer)))
   :deriving(Show))

  (:data (Modular-classify)((Negative-unity)(Unity)(Number)))

  (:fun classify(Modular-classify)((n(Integer))(modulo-p(Integer)))
   (:case (== n (- modulo-p 1))
    ((True)Negative-unity)
    ((_)(:case (== n 1)
         ((True)Unity)
         ((_)Number)
         ))))

  (:fun modular-exponentiation(Integer)
   ((a(Integer))(n(Integer))(modulo-p(Integer)))
   (:where
    (peek-more end-show
     (:case (compare n 1)
      ((EQ)a)
      ((GT)
       (:case (mod n 2)
        ((0)(:where (modular-square result modulo-p) 
             (:fun result(Integer)()
              (modular-exponentiation a (div n 2) modulo-p)
              )))
        ((_)
         (mod (* a
               (modular-exponentiation a (- n 1) modulo-p))
          modulo-p))
        ))))
    (:fun end-show(:list(String))((x(Integer)))
     (:mlist "modular-exponentiation "(show a)" "(show n)" = "(show x)))
    ))
  
  (:fun modular-square(Integer)((result(Integer))(modulo-p(Integer)))
   (mod(* result result)modulo-p))

  (:fun modular-square-miller-rabin(Miller-rabin-result)
   ((x(Miller-rabin-result))(modulo-p(Integer)))
   (:case x
    ((N(n))(N(modular-square n modulo-p)))
    ((_)x)))
       
  (:fun primes(:list(Integer))()
   (:cons-list 2 eratosthenes-sieve))

  (:fun eratosthenes-sieve(:list(Integer))()
   (filter by-eratosthenes (enumFrom 3)))
  (:fun by-eratosthenes(Bool)((x(Integer)))
   (and (map (indivisible x)(takeWhile (lt-sqrt x) primes))))
  (:fun lt-sqrt(Bool)((x(Integer))(p(Integer)))
   (<= (* p p)x))
  (:fun indivisible(Bool)((big(Integer))(small(Integer)))
   (/= 0 (mod big small)))

  (:fun exhaustive-miller-rabin(Integer)((x(Integer)))
   (genericLength(filter id(map (miller-rabin-1 x) (enumFromTo 2 (- x 2))))))

  (:fun is-interesting(Bool)
   ((exhaustive-miller-rabin-result(:tuple(Integer)(Integer))))
   (:case exhaustive-miller-rabin-result
    ((:ptuple(a)(b)) (&&(/= b 1)(/= a (b+2))))))
    
  (:fun ip-fast(Bool)((x(Integer)))
   (miller-rabin-1 x 2))
  (:fun good(Bool)((x(Integer)))
   (and (:mlist [(ip-fast x)] (ip-fast (+ 1(* 2 x)))
         (ip-fast (+ 1(* 4 x))))))
  (:fun make-good(Integer)((x(Integer)))
   (* (+ 1(* 2 x)) (+ 1(* 4 x))))
  
  (:fun high-witnesses(IO :unit)((l(:list(Integer))))
   (putStr (show-list (filter is-interesting
                       (zip-map exhaustive-miller-rabin l)))))
  
  (:fun double-is-prime(Bool)((x(:tuple(Integer)(Integer))))
   (&& (miller-rabin-1 (fst x) 2)(miller-rabin-1 (snd x)2)))

  (:fun diff-sub(:list(Integer))
   ((many (:list(Integer)))(some (:list(Integer))))
   (:case (:mtuple many some)
    ((:ptuple (:cons(h-many)(t-many))(:cons(h-some)(t-some)))
     (:case (compare h-many h-some)
      ((LT)(:mcons h-many (diff-sub t-many some)))
      ((EQ)(diff-sub t-many t-some))
      ((GT)(diff-sub many t-some))
      ))))
  (:fun in-desired-range(Bool)((p(Integer))(num-wit(Integer)))
   (&& (< (* 2 num-wit) p) (< p (* 5 num-wit))))

  (:fun mersenne(Integer)((x(Integer)))
    (-(^ 2 x)1))

  (:fun sub-fib(:list(Integer))()
    (:mcons 1 (:mcons 1(:mcons 1(zipWith + sub-fib (tail (tail sub-fib)))))))

  (:fun sub-fib-numbered(:list(:tuple(Integer)(Int)))()
    (zip sub-fib (enumFrom 0)))
  
  (:fun two-powers(IO :unit)((start(Int))(next(Int)))
    (mapM- single-two-power (enumFromThen start next)))

  (:fun two-powers-sieve(IO :unit)((start(Int))(next(Int)))
    (mapM- sievers-two-power (enumFromThen start next)))

  (:fun run-sequence(IO :unit)((fun(:fn(IO :unit)((exponent(Int)))))
                               (start(Int))(by(Int)))
    (run-sequence-on fun (enumFromThen start (+ start by)) )
    [(mapM- fun )])
  
  (:fun run-sequence-on(IO :unit)((fun(:fn(IO :unit)((exponent(Int)))))
                                  (sequence(:list(Int))))
    (mapM- fun sequence))

  (:fun logn-sequence-from-by(:list(Int))((start(Int))(by(Int)))
    (:pipe (dropWhile (> start )) (map n-log-n (enumFromThen 1 (+ 1 by)))))
    
  
  (:fun is-prime-offset(Bool)((base(Integer))(offset(Integer)))
    (is-prime (+ base  offset ))
    )
  
  (:fun prime-filter-offset(:list(Integer))((base(Integer))(l(:list(Integer))))
    (filter (is-prime-offset base) l )
    )

  (:fun single-two-power(IO :unit)((s(Int)))
    (:where
     (:do
     (putStr (show s))
     (putStr " ")
     (:pipe
      putStrLn (show)  (++ (reverse b) a))
     )
     (:fun a(:list(Integer))()
       (take 10 (prime-filter-offset (two-pow s) (enumFrom 0))))
     (:fun b(:list(Integer))()
       (take 10 (prime-filter-offset (two-pow s)
                                     (map negate (enumFrom 1)))))
     ))

  
  (:fun num-neighbors(Int)()3)
  
  (:fun sievers-two-power(IO :unit)((exponent(Int)))
    (:where
     (:do
      (putStr (show exponent))
      (putStr " ")
      (:pipe
       putStrLn (show)  (++ (reverse b) a))
      )
     (:fun base-point(Integer)()(^ 2 (fromIntegral exponent)))
     (:fun a(:list(Integer))()
       (:pipe (take num-neighbors)
              (prime-filter-offset base-point)
              (map fst)
              (filter snd)
              (sieve-forward base-point)
              ))
     (:fun b(:list(Integer))()
       (:pipe (take num-neighbors)
              (prime-filter-offset base-point)
              (map fst)
              (filter snd)
              (sieve-backward base-point)
              )
       )))

  (:fun test-print(IO :unit)((exponent(Int)))
    (:where
     (:do
      (putStr (show exponent))
      (putStr " ")
      
      (putStrLn (show a))
      
      )
     (:fun base-point(Integer)()(^ 2 (fromIntegral exponent)))
     (:fun a(:list(Integer))()
       (:pipe (twin-process base-point)
              [(zip (enumFrom 0) (repeat True))]
              (sieve-forward base-point)
              ))
     
     )
    )
  (:fun powers-of-two(:list(Int))()
    (:mcons 4 (map (* 2) powers-of-two)))
  (:fun sophie-germain-sieve(IO :unit)
    ((sieve-direction(:fn(:list(:tuple(Integer)(Bool)))
                         ((base-point(Integer)))))
     (exponent(Int)))
    (:where
     (:do
      (putStr "2^")
      (putStr (show exponent))
      (putStr " + ")
      (:pipe
       putStrLn
       show
       (map fst)
       (take 1)
       (filter snd)
       (zip-map (sg-delta base-point))
       (map fst)
       (filter snd)
       (sieve-direction base-point)
       ))
     (:fun base-point(Integer)()(two-pow exponent))
     ))

  (:fun two-pow(Integer)((exponent(Int)))
    (^ 2 (fromIntegral exponent)))
  
  (:fun sophie-germain(IO :unit)((direction(:list(Integer)))
                                 (exponent(Int)))
    (:do
     (putStr "2^")
     (putStr (show exponent))
     (putStr " + ")
     (:pipe
      putStrLn
      show
      (map fst)
      (take 2)
      (filter snd)
      (zip-map (sg-delta (two-pow exponent)))
      direction
      
      )))
  (:fun sg-delta(Bool)((base-point(Integer))(delta(Integer)))
    (is-sophie-germaine-prime-minor
     (+ delta base-point)))
      
     

  (:fun twin-primes(IO :unit)((exponent(Int)))
    (:where
     (:do
      (putStr (show exponent))
      (putStr " ")
      [(putStr (show a))
       (putStrLn (show b))]
      (:pipe
       putStrLn show  (++ (reverse b) a))
      )
     (:fun base-point(Integer)()(^ 2 (fromIntegral exponent)))
     (:fun a(:list(Integer))()
       (:pipe (twin-process base-point)
              (sieve-forward base-point)
              ))
     (:fun b(:list(Integer))()
       (:pipe (twin-process base-point)
              (sieve-backward base-point)
              ))
     ))
      
  (:fun twin-process-old (:list(Integer))
    ((base-point(Integer))(candidates(:list(:tuple(Integer)(Bool)))))
    (:pipe
     (take 10)
     (map ((flip !!) 1))
     (filter (is-really-twin-prime base-point))
     (map (map fst))
     (filter twin-positive)
     (ntakes 3)
     candidates
     ))

  (:fun twin-process-2 (:list(Int))
    ((base-point(Integer))(candidates(:list(:tuple(Int)(Bool)))))
    (:pipe
     (take 10)
     
     (map fst)
     (filter snd)
     (map (twin-real-test-2 base-point))
     tails
     candidates
     ))
  

  (:fun twin-process (:list(Integer))
    ((base-point(Integer))(candidates(:list(:tuple(Integer)(Bool)))))
    (:pipe
     (take 10)
     [(map ((flip !!) 1))
      (filter (is-really-twin-prime base-point))
      (map (map fst))
      (filter twin-positive)
      (ntakes 3)]
     (map fst)
     (filter snd)
     (map (twin-real-test base-point))
     tails
     candidates
     ))

  (:fun twin-real-test(:tuple(Integer)(Bool))
    ((base-point(Integer))
     (candidates-tail (:list(:tuple(Integer)(Bool)))))
    (:case candidates-tail
      ((:cons(:ptuple(a)(True))
             (:cons(:ptuple(middle)(_))
                   (:cons(:ptuple(b)(True))(_))))
       (:mtuple middle
                (&&(is-prime-offset base-point a)
                       (is-prime-offset base-point b))))
      ((_)(:mtuple 0 False)))
    )
  
  (:fun twin-real-test-2(:tuple(Int)(Bool))
    ((base-point(Integer))
     (candidates-tail (:list(:tuple(Int)(Bool)))))
    (:case candidates-tail
      ((:cons(:ptuple(a)(True))
             (:cons(:ptuple(middle)(_))
                   (:cons(:ptuple(b)(True))(_))))
       (:mtuple middle
                (&&
                 (< 10000000 a)
                 (< 10000000 b))))
      ((_)(:mtuple 0 False)))
    )


  (:fun sieve-backward(:list(:tuple(Integer)(Bool)))((base-point(Integer)))
    (:pipe
     (zip (map negate (enumFrom 1)))
     (map and)
     (many-sievers-reverse base-point num-primes-to-sieve)
     [(cycle (:mlist True False))]
     ))
  

  (:fun twin-positive(Bool)((x(:list (:tuple(a)(Bool)))))
    (:case x
      ((:plist(:ptuple(_)(True))(_)(:ptuple(_)(True)))True)
      ((_)False)))
  
  (:fun sieve-forward(:list(:tuple(Integer)(Bool)))((base-point(Integer)))
    (:pipe
     (zip (enumFrom 0))
     [(cycle (:mlist False True))]
     (map and)
     (many-sievers base-point num-primes-to-sieve)
     ))

  [(:fun twin-primes
    (:pipe (filter twin-positive) (ntakes 3) (sieve-forward 100)))]
  
  (:fun num-primes-to-sieve(Int)()5)

  (:fun is-really-twin-prime(Bool)((base(Integer))(l(:list(Integer))))
    (&& (is-prime-offset base (!! l 0))
        (is-prime-offset base (!! l 2))))

  (:fun siever(:list(Bool))((start(Integer))(modulo(Int)))
    (:pipe 
     (take modulo)
     (map (:compose (/= 0)((flip mod)modulo)))
     (enumFrom (fromInteger(mod start (fromIntegral modulo))))
     ))

  (:fun siever-by(:list(Bool))((start(Integer))(by-count(Int))(modulo(Int)))
	(:pipe
	 (take modulo)
	 (map (:compose (/=0) ((flip mod)modulo))
	      (enum-from-by (fromInteger (mod start (fromIntegral modulo)))
			  by-count))))

  
  (:fun many-sievers (:list(:list(Bool))) ((start(Integer))(num(Int)))
    (:where
     (:pipe transpose
           (map (:compose cycle (siever start)) )
           first-num-primes)
     (:fun first-num-primes(:list(Int))()
       (map fromInteger(take num primes)))
     ))

  (:fun many-sievers-reverse (:list(:list(Bool))) ((start(Integer))(num(Int)))
    (:where
     (:pipe transpose
           (map (:compose cycle reverse (siever start)) )
           first-num-primes)
     (:fun first-num-primes(:list(Int))()
       (map fromInteger(take num primes)))
     ))

  
  (:fun is-sophie-germaine-prime-minor(Bool)((p(Integer)))
    (&& (is-prime (div (- p 1) 2))
        (is-prime p)
        ))
  (:fun is-sophie-germaine-prime(Bool)((p(Integer)))
    (&& (is-prime p)
        (is-prime (+ 1 (* 2 p)))
        ))

  (:fun negatives(:list(Integer))()
    (enumFromThen (negate 1) (negate 2)))
  (:fun positives(:list(Integer))()
    (enumFrom 1))
  (:fun halfways(:list(Int))((l(:list(Int))))
    (:case l
      ((:cons(a) (:as rest (:cons(b)(_))))
       (:mcons a (:mcons (div (+ a b) 2) (halfways rest))))))

  (:fun hh-powers-of-two(:list(Int))()
    (halfways (halfways powers-of-two)))
  
  (:fun sophie-germain-caveat(IO :unit)()
    (:do
     (putStrLn "Here are some primes p such that p and (p-1)/2 are both prime. The corresponding")
     (putStrLn "Sophie Germain prime is (p-1)/2.")
     ))
  (:fun hh-powers-of-two-from(:list(Int))((minimum(Int)))
    (dropWhile (>= minimum)
               hh-powers-of-two))

  (:fun smaller-factors(:list(Int))((n(Int)))
	(:where
	 (takeWhile sqrt-smaller(map fromInteger primes))
	 (:fun sqrt-smaller(Bool)((p(Int)))
	       (<= (* p p)n))
	 ))

  (:fun factor :no-sig (:list(:tuple(Int)(Int))) ((n(Int)))
	(:where
	 (:pipe
	  (filter sndpositive)
	  (factor-l (smaller-factors n) n))
	 (:fun sndpositive :no-sig (Bool) ((x(IntInt)))
	       (< 0 (snd x)))
	 ))
  (:fun factor-l :no-sig (:list(:tuple(Int)(Int)))((list-factors(Int))(victim(Int)))
	(:case victim
	       ((1)(:mlist))
	       ((_)(:case list-factors
			  ((:nil)(:mlist(:mtuple victim 1)))
			  ((_)
			   (:where
			    (:mcons (:mtuple (head list-factors) (fst p))
				    (factor-l (tail list-factors) (snd p)))
			    (:fun p :no-sig (X) ()
				  (divide-through victim (head list-factors)))))))))

  (:fun divide-through :no-sig (:tuple(Int)(Int)) ((victim(Int))(primefactor(Int)))
	(:case (mod victim primefactor)
	       ((0)(:where
		    (:mtuple(+ 1 (fst final))(snd final))
		    (:fun final :no-sig (Bar) () (divide-through (div victim primefactor) primefactor))
		    ))
	       ((_)(:mtuple 0 victim))))

  (:fun big-product-prime (Integer)()(product(take 1000 primes)))
  (:fun gcd-test(Integer)((n(Integer)))
	(gcd n big-product-prime))
  (:fun mersenne-gcd-test (Integer)((n(Integer)))
	(gcd-test
	 (mod (pred(+ big-product-prime (modular-exponentiation 2 n big-product-prime)))
	      big-product-prime)))
  (:fun main(IO :unit)()
   (:do
    (hSetBuffering stdout LineBuffering)
    (hPutStrLn stdout rcs-code)
    (:= args getArgs)
    (hPutStrLn stdout (show args))
    (putStrLn (:cc "% num-primes-to-sieve " (show num-primes-to-sieve)))
    (:case args
      ((:plist(:pstring"primes")(num))(:pipe putStr show-list (take (read num) primes)))
      ((:plist(:pstring "sub-fib"))
       (:pipe putStr show-list
              (filter (:compose is-prime fst))
              sub-fib-numbered))
      ((:plist(:pstring "sub-fib-squares"))
       (error "no"))
      ((:plist(:pstring "two-powers")(start)(next))(two-powers(read start)(read next)))
      ((:plist(:pstring "two-powers-sieve")(start)(next))(two-powers-sieve(read start)(read next)))
      ((:plist(:pstring "single-two-power")(x))
       (single-two-power (read x)))
      ((:plist(:pstring "many-sievers")(x))
       (:pipe
        putStr show-list (take 10)
        (filter (:compose is-prime (+ (^ 2 1000)) fst))
        (filter snd) (zip (enumFrom 0)) (map and) (many-sievers (^ 2 1000) (read x))))
      ((:plist(:pstring "sievers-two-power")(s))(sievers-two-power (read s)))
      ((:plist(:pstring "twin-primes")(start)(by))
       (run-sequence twin-primes (read start) (read by)))
      ((:plist(:pstring "twin-primes-l")(start)(by))
       (run-sequence-on twin-primes
                        (logn-sequence-from-by (read start) (read by))))
      
      
      ((:plist(:pstring "sophie-germain")(start)(by))
       (run-sequence (sophie-germain negatives)
                     (read start) (read by)))

      ((:plist(:pstring "sophie-germain-powers-of-two-minus")(minimum))
       (:do
        sophie-germain-caveat
       (mapM- [(sophie-germain negatives)]
              (sophie-germain-sieve sieve-backward)
              (hh-powers-of-two-from (read minimum)))))
      ((:plist(:pstring "test-sophie")(value))
              (sophie-germain-sieve sieve-backward  (read value)))

      ((:plist(:pstring "sophie-germain-powers-of-two-plus")(minimum))
       (:do
        sophie-germain-caveat
        (mapM- [(sophie-germain positives)]
               (sophie-germain-sieve sieve-forward)
               (hh-powers-of-two-from (read minimum))
               )))

      ((:plist(:pstring "primes-hh")(minimum))
       (:do
        (run-sequence-on sievers-two-power
                         (hh-powers-of-two-from (read minimum)))))

      

      ((:plist(:pstring "test")(x))(twin-primes (read x)))
      ((:plist(:pstring "test-is-prime")(base)(exponent)(delta))
       (:pipe putStrLn show is-prime (+ (^ (read base) (read exponent))
                                        (read delta))))
      ((:plist(:pstring "test-print")(start)(by))
       (run-sequence test-print (read start) (read by)))
      ((:plist(:pstring "many-sievers-test"))
       (:pipe print length (filter id) (map and) (many-sievers 0 num-primes-to-sieve)))
      ((:plist(:pstring "time-modexp")(bits))
       (:where
        (:pipe putStrLn show (modular-exponentiation 2 (- mers 1) mers))
        (:fun mers(Integer)()(- (^ 2 (read bits))1))
        ))
      ((:plist(:pstring "sierp")(test-val)(k)(n))
       (:where
        (:do
         
        (:pipe putStrLn show (== 1)
               (modular-exponentiation (read test-val) v p))
        (:pipe putStrLn show (== 1)
               (modular-exponentiation (read test-val) (div (- p 1)2) p))
        (putStrLn "==")
        (:pipe putStrLn show (miller-rabin-1 p 2))
        
        )
        (:fun p(Integer)() (+ 1(* m v )))
        (:fun m(Integer)()(read k))
        (:fun v(Integer)()(^ 2 (read n)))
        ))
     )
    
    [(high-witnesses (enumFromThen (read (!! args 0)) (read (!! args 1))))]
    [(high-witnesses (map (uncurry *)
                      (filter double-is-prime
                       (zip (enumFromThen 3 5) (enumFromThen 5 9)))))]
    [(high-witnesses (map make-good (filter good (enumFromThen 3 5))))]
    [(:pipe
     putStr show-list (map fst)(filter snd)
     (zip-map (:compose is-prime mersenne))
     primes)]
    [(:pipe
      putStr show-list
      (filter (uncurry in-desired-range))
      (zip-map exhaustive-miller-rabin [(enumFromThen 703 705)])
      (map make-good (enumFrom 1))
      )]
    ))
  ))
[
 ((9,1),14.285714285714286)
 ((25,3),13.043478260869565)
 ((49,5),10.638297872340425)
 ((91,17),19.10112359550562)
 ((133,17),12.977099236641221)
 ((341,49),14.454277286135694)
 ((451,49),10.913140311804009)
 ((481,53),11.064718162839249)
 ((703,161),22.96718972895863)
 ((1387,161),11.624548736462094)
 ((1541,241),15.659519168291098)
 ((1891,449),23.769190047644255)
 ((2047,241),11.78484107579462)
 ((2701,485),17.969618377176733)
 ((4033,485),12.031753907219052)
 ]
[
 paris:~/www/three/prime/code% time ./x.primes-2.ll.Ox single-two-power 1000
$Id: primes-2.ll,v 1.313 2006/10/29 22:12:28 kenta Exp $
["single-two-power","1000"]
1000 [297,4081,5343,6475,6793,9577,10221,10627,10837,10873]
213.710u 0.290s 3:35.10 99.4%   0+0k 0+0io 170pf+0w
]
[(progn (emacs-lisp-mode) (power-brackets) (switch-semi-and-colon) (font-lock-mode) (paren-set-mode 'sexp-surround))]