TOP
Gaucheで各種測量計算
SchemeインタプリタGaucheで各種測量計算するスクリプトsurveyscmです。
計算内容は
トラバース計算
逆トラバース計算
幅杭計算(直線)
幅杭計算(曲線)
垂線計算
交点計算
交点計算(円直線)
交点計算(円円)
縦断曲線計算
ヘロン面積計算
座標面積計算
単曲線計算
三角形の解法
座標計算
逆計算
クロソイド曲線計算
高さ(比例)計算
集計計算
水準計算
垂線計算(円)
楕円計算
台形計算
測量計算のアルゴリズムは、
あさかぜネットのCASIO FX-603Pの測量計算実行マニュアルを参考にしています。
動作環境はGauche-0.9.10で確認しています。
最新版のGaucheでも動作すると思います。
surveyscm-0.15.zip
surveyscm-0.15.tar.gz
surveyscm-0.15.tar.gz を展開してカレントディレクトリから ./surveyscm.scm を実行してください。
CASIO FX-603P
測量計算に興味のある方はSchemeスクリプトを自由に改変してお使いください。
Schemeスクリプトを書くにあたって参考にした書籍
オライリー・ジャパン 「プログラミングGauche」
Kahuaプロジェクト (著) 川合史朗 (監修)
東海大学出版会 「素数夜曲 女王陛下のLISP」
吉田武 (著)
surveyscm.scm の実行例
トラバース計算の実行例
クロソイド曲線計算の実行例
;;-----------------------------------------------------------------------------
;; calc/surveymod.scm
(define-module surveymod
(export add180 add360 cut360
addtail addtail2
convert10->60 convert60->10
degrees360? degrees180?
heron heron?))
(select-module surveymod)
(use srfi-13)
(define-syntax add180
(syntax-rules ()
((add180 a)
(if (< a 0)
(+ a 180)
(+ a 0)) )))
(define-syntax add360
(syntax-rules ()
((add360 a)
(if (< a 0)
(+ a 360)
(+ a 0)) )))
(define-syntax cut60
(syntax-rules ()
((cut60 a)
(if (= a 60)
(- a 60)
(+ a 0)) )))
(define-syntax add1
(syntax-rules ()
((add1 a b)
(if (= a 60)
(+ b 1)
(+ b 0)) )))
(define-syntax cut360
(syntax-rules ()
((cut360 a)
(if (>= a 360)
(- a 360)
(+ a 0)) )))
(define-syntax addzero
(syntax-rules ()
((addzero a)
(if (<= 0 a 9)
(string-append "0" (x->string a))
(x->string a)) )))
(define-syntax addzero00
(syntax-rules ()
((addzero00 a)
(if (= 1 (string-scan a ".")) (string-append "00" a)
(if (= 2 (string-scan a ".")) (string-append "0" a)
(if (= 3 (string-scan a ".")) (string-append "" a)
(string-append "" a)))) )))
(define-syntax addtail
(syntax-rules ()
((addtail x)
(let* (
(at1 (/ (round (* 1000 x)) 1000))
(at2 (exact->inexact at1))
(at3 (string-reverse (x->string at2)))
(at4 (addzero00 at3))
(at5 (string-reverse at4))
)
at5) )))
#|
(define-syntax addtail
(syntax-rules ()
((addtail a)
((lambda (x) (string-reverse
(addzero00
(string-reverse
(x->string
(exact->inexact
(/ (round (* 1000 a)) 1000))))))) addtail) )))
|#
(define-syntax addtail2
(syntax-rules ()
((addtail2 x)
(let* (
(at1 (/ (truncate (* 1000 x)) 1000))
(at2 (exact->inexact at1))
(at3 (string-reverse (x->string at2)))
(at4 (addzero00 at3))
(at5 (string-reverse at4))
)
at5) )))
#|
(define-syntax addtail2
(syntax-rules ()
((addtail2 a)
((lambda (x) (string-reverse
(addzero00
(string-reverse
(x->string
(exact->inexact
(/ (truncate (* 1000 a)) 1000))))))) addtail2) )))
|#
(define-syntax convert10->60
(syntax-rules ()
((convert10->60 kaku)
(let* (
(kakudo-do1 (truncate->exact kaku))
(kakudo-fun1 (- kaku kakudo-do1))
(kakudo-fun2 (* 60 kakudo-fun1))
(kakudo-fun3 (truncate->exact kakudo-fun2))
(kakudo-byou1 (- kakudo-fun2 kakudo-fun3))
(kakudo-byou2 (* 60 kakudo-byou1))
(kakudo-byou3 (round->exact kakudo-byou2))
(kakudo-byou4 (cut60 kakudo-byou3))
(kakudo-byou5 (addzero kakudo-byou4))
(kakudo-fun4 (add1 kakudo-byou3 kakudo-fun3))
(kakudo-fun5 (cut60 kakudo-fun4))
(kakudo-fun6 (addzero kakudo-fun5))
(kakudo-do2 (add1 kakudo-fun4 kakudo-do1))
(kakudo-do3 (cut360 kakudo-do2))
(kakudo-do4 (x->string kakudo-do3))
(kakudo-do-fun-byou1
(string-append
kakudo-do4 "-" kakudo-fun6 "-" kakudo-byou5))
)
kakudo-do-fun-byou1) )))
#|
(define-syntax convert10->60
(syntax-rules ()
((convert10->60 kaku)
((lambda (x)
(string-append
(x->string
(cut360
(add1
(add1
(round->exact
(* 60 (- (* 60 (- kaku (truncate->exact kaku)))
(truncate->exact (* 60 (- kaku (truncate->exact kaku)))))))
(truncate->exact (* 60 (- kaku (truncate->exact kaku)))))
(truncate->exact kaku))))
"-"
(addzero
(cut60
(add1
(round->exact
(* 60 (- (* 60 (- kaku (truncate->exact kaku)))
(truncate->exact (* 60 (- kaku (truncate->exact kaku)))))))
(truncate->exact (* 60 (- kaku (truncate->exact kaku)))))))
"-"
(addzero
(cut60
(round->exact
(* 60 (- (* 60 (- kaku (truncate->exact kaku)))
(truncate->exact (* 60 (- kaku (truncate->exact kaku)))))))))
)) convert10->60) )))
|#
(define-syntax convert60->10
(syntax-rules ()
((convert60->10 kaku)
(let* (
(kakudo1 (x->string kaku))
(kakudo-do1 (string-drop-right kakudo1 6))
(kakudo-fun1 (string-take-right (string-drop-right kakudo1 3) 2))
(kakudo-byou1 (string-take-right kakudo1 2))
(kakudo-do2 (x->number kakudo-do1))
(kakudo-fun2 (x->number kakudo-fun1))
(kakudo-byou2 (x->number kakudo-byou1))
(kakudo-do3 (*. kakudo-do2 (expt 60 0)))
(kakudo-fun3 (*. kakudo-fun2 (expt 60 -1)))
(kakudo-byou3 (*. kakudo-byou2 (expt 60 -2)))
(kaku1 (+ kakudo-do3 kakudo-fun3 kakudo-byou3))
)
kaku1) )))
#|
(define-syntax convert60->10
(syntax-rules ()
((convert60->10 kaku)
((lambda (x)
(+
(*. (expt 60 0)
(x->number (string-drop-right (x->string kaku) 6)))
(*. (expt 60 -1)
(x->number (string-take-right
(string-drop-right (x->string kaku) 3) 2)))
(*. (expt 60 -2)
(x->number (string-take-right (x->string kaku) 2)))
)) convert60->10) )))
|#
(define-syntax degrees360?
(syntax-rules ()
((degrees360? kaku)
(not (or
(>= 6 (string-length (x->string kaku)))
(<= 10 (string-length (x->string kaku)))
(not (char-numeric? (string-ref
(string-reverse (x->string kaku)) 0)))
(not (char-numeric? (string-ref
(string-reverse (x->string kaku)) 1)))
(not (char=? (ucs->char 45) (string-ref
(string-reverse (x->string kaku)) 2)))
(not (char-numeric? (string-ref
(string-reverse (x->string kaku)) 3)))
(not (char-numeric? (string-ref
(string-reverse (x->string kaku)) 4)))
(not (char=? (ucs->char 45) (string-ref
(string-reverse (x->string kaku)) 5)))
(if (= 7 (string-length (x->string kaku)))
(or
(not (char-numeric? (string-ref
(string-reverse (x->string kaku)) 6)))
(not (> 60 (x->number (string-take-right
(x->string kaku) 2))))
(not (> 60 (x->number
(string-take-right
(string-drop-right
(x->string kaku) 3) 2))))
)
(if (= 8 (string-length (x->string kaku)))
(or
(not (char-numeric? (string-ref
(string-reverse (x->string kaku)) 6)))
(not (char-numeric? (string-ref
(string-reverse (x->string kaku)) 7)))
(not (> 60 (x->number (string-take-right
(x->string kaku) 2))))
(not (> 60 (x->number
(string-take-right
(string-drop-right
(x->string kaku) 3) 2))))
)
(if (= 9 (string-length (x->string kaku)))
(or
(not (char-numeric? (string-ref
(string-reverse (x->string kaku)) 6)))
(not (char-numeric? (string-ref
(string-reverse (x->string kaku)) 7)))
(not (char-numeric? (string-ref
(string-reverse (x->string kaku)) 8)))
(not (> 60 (x->number (string-take-right
(x->string kaku) 2))))
(not (> 60 (x->number
(string-take-right
(string-drop-right
(x->string kaku) 3) 2))))
(not (> 360 (x->number
(string-drop-right
(x->string kaku) 6))))
) ))) ) ) )))
(define-syntax degrees180?
(syntax-rules ()
((degrees180? kaku)
(not (or
(>= 6 (string-length (x->string kaku)))
(<= 10 (string-length (x->string kaku)))
(not (char-numeric? (string-ref
(string-reverse (x->string kaku)) 0)))
(not (char-numeric? (string-ref
(string-reverse (x->string kaku)) 1)))
(not (char=? (ucs->char 45) (string-ref
(string-reverse (x->string kaku)) 2)))
(not (char-numeric? (string-ref
(string-reverse (x->string kaku)) 3)))
(not (char-numeric? (string-ref
(string-reverse (x->string kaku)) 4)))
(not (char=? (ucs->char 45) (string-ref
(string-reverse (x->string kaku)) 5)))
(if (= 7 (string-length (x->string kaku)))
(or
(not (char-numeric? (string-ref
(string-reverse (x->string kaku)) 6)))
(not (> 60 (x->number (string-take-right
(x->string kaku) 2))))
(not (> 60 (x->number
(string-take-right
(string-drop-right
(x->string kaku) 3) 2))))
)
(if (= 8 (string-length (x->string kaku)))
(or
(not (char-numeric? (string-ref
(string-reverse (x->string kaku)) 6)))
(not (char-numeric? (string-ref
(string-reverse (x->string kaku)) 7)))
(not (> 60 (x->number (string-take-right
(x->string kaku) 2))))
(not (> 60 (x->number
(string-take-right
(string-drop-right
(x->string kaku) 3) 2))))
)
(if (= 9 (string-length (x->string kaku)))
(or
(not (char-numeric? (string-ref
(string-reverse (x->string kaku)) 6)))
(not (char-numeric? (string-ref
(string-reverse (x->string kaku)) 7)))
(not (char-numeric? (string-ref
(string-reverse (x->string kaku)) 8)))
(not (> 60 (x->number (string-take-right
(x->string kaku) 2))))
(not (> 60 (x->number
(string-take-right
(string-drop-right
(x->string kaku) 3) 2))))
(not (> 180 (x->number
(string-drop-right
(x->string kaku) 6))))
) ))) ) ) )))
(define-syntax heron
(syntax-rules ()
((heron a b c)
(let* (
(s (/ (+ a b c) 2))
(t (sqrt (* s (- s a) (- s b) (- s c))))
)
t) )))
#|
(define-syntax heron
(syntax-rules ()
((heron a b c)
((lambda (t) (sqrt (* (/ (+ a b c) 2)
(- (/ (+ a b c) 2) a)
(- (/ (+ a b c) 2) b)
(- (/ (+ a b c) 2) c))) ) heron) )))
|#
(define-syntax heron?
(syntax-rules ()
((heron? a b c)
(and (> (+ a b) c)
(> (+ b c) a)
(> (+ c a) b)
) )))
(provide "surveymod")
;;-----------------------------------------------------------------------------
;; calc/survey-00.scm
(define-module survey-00
(export traverse-calc))
(select-module survey-00)
(add-load-path ".")
(use surveymod)
(use math.const)
(define (traverse-calc)
(newline)
(let loop0 ((count 1))
(print "トラバース計算")
(newline)
(let loop-01 ((count 1))
(print "後視点 Ｘ座標")
(let ((back-x (read)))
(if (not (real? back-x))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "後視点 Ｙ座標")
(let ((back-y (read)))
(if (not (real? back-y))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop-03 ((count 1))
(print "器械点 Ｘ座標")
(let ((kikai-x (read)))
(if (not (real? kikai-x))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(let loop-04 ((count 1))
(print "器械点 Ｙ座標")
(let ((kikai-y (read)))
(if (not (real? kikai-y))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-04 (+ count 1)))
(begin
(let loop1 ((count 1))
(let loop-05 ((count 1))
(print "夾角 0-00-00 から 359-59-59")
(let ((kyou-kaku (read)))
(if (not (degrees360? kyou-kaku))
(begin (newline)
(print "夾角を入力してください")
(newline)
(loop-05 (+ count 1)))
(begin
(let loop-06 ((count 1))
(print "距離")
(let ((zenshi-kyori (read)))
(if (not (real? zenshi-kyori))
(begin (newline)
(print "距離を入力してください")
(newline)
(loop-06 (+ count 1)))
(if (negative? zenshi-kyori)
(begin (newline)
(print "距離を入力してください")
(newline)
(loop-06 (+ count 1)))
(begin
(let* (
(koushi-houkou-kaku1
(* (atan (- back-y kikai-y) (- back-x kikai-x)) 180/pi))
(koushi-houkou-kaku2 (add360 koushi-houkou-kaku1))
(kyou-kaku1 (convert60->10 kyou-kaku))
(zenshi-houkou-kaku1 (+ koushi-houkou-kaku2 kyou-kaku1))
(zenshi-houkou-kaku2 (cut360 zenshi-houkou-kaku1))
(zenshi-x1 (* zenshi-kyori (cos (* zenshi-houkou-kaku2 pi/180))))
(zenshi-x2 (+ kikai-x zenshi-x1))
(zenshi-x3 (addtail zenshi-x2))
(zenshi-y1 (* zenshi-kyori (sin (* zenshi-houkou-kaku2 pi/180))))
(zenshi-y2 (+ kikai-y zenshi-y1))
(zenshi-y3 (addtail zenshi-y2))
(koushi-houkou-kaku3 (convert10->60 koushi-houkou-kaku2))
(zenshi-houkou-kaku3 (convert10->60 zenshi-houkou-kaku2))
)
(newline)
(print "前視Ｘ座標 " zenshi-x3)
(print "前視Ｙ座標 " zenshi-y3)
(newline)
(print "後視方向角 " koushi-houkou-kaku3)
(print "前視方向角 " zenshi-houkou-kaku3)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
)))))))))))))))))))))))))))))))
(provide "survey-00")
;;-----------------------------------------------------------------------------
;; calc/survey-01.scm
(define-module survey-01
(export inverse-calc))
(select-module survey-01)
(add-load-path ".")
(use surveymod)
(use math.const)
(define (inverse-calc)
(newline)
(let loop0 ((count 1))
(print "逆トラバース計算")
(newline)
(let loop-01 ((count 1))
(print "後視点 Ｘ座標")
(let ((back-x (read)))
(if (not (real? back-x))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "後視点 Ｙ座標")
(let ((back-y (read)))
(if (not (real? back-y))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop-03 ((count 1))
(print "器械点 Ｘ座標")
(let ((kikai-x (read)))
(if (not (real? kikai-x))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(let lopp-04 ((count 1))
(print "器械点 Ｙ座標")
(let ((kikai-y (read)))
(if (not (real? kikai-y))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-04 (+ count 1)))
(begin
(let loop1 ((count 1))
(let loop-05 ((count 1))
(print "前視点 Ｘ座標")
(let ((front-x (read)))
(if (not (real? front-x))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-05 (+ count 1)))
(begin
(let lopp-06 ((count 1))
(print "前視点 Ｙ座標")
(let ((front-y (read)))
(if (not (real? front-y))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-06 (+ count 1)))
(begin
(let* (
(zenshi-kyori1
(sqrt (+ (expt (- front-y kikai-y) 2)
(expt (- front-x kikai-x) 2))))
(zenshi-kyori2 (addtail zenshi-kyori1))
(koushi-houkou-kaku1
(* (atan (- back-y kikai-y) (- back-x kikai-x)) 180/pi))
(koushi-houkou-kaku2 (add360 koushi-houkou-kaku1))
(zenshi-houkou-kaku1
(* (atan (- front-y kikai-y) (- front-x kikai-x)) 180/pi))
(zenshi-houkou-kaku2 (add360 zenshi-houkou-kaku1))
(kyou-kaku1 (- zenshi-houkou-kaku2 koushi-houkou-kaku2))
(kyou-kaku2 (add360 kyou-kaku1))
(kyou-kaku3 (convert10->60 kyou-kaku2))
(koushi-houkou-kaku3 (convert10->60 koushi-houkou-kaku2))
(zenshi-houkou-kaku3 (convert10->60 zenshi-houkou-kaku2))
)
(newline)
(print "夾角 " kyou-kaku3)
(print "距離 " zenshi-kyori2)
(newline)
(print "後視方向角 " koushi-houkou-kaku3)
(print "前視方向角 " zenshi-houkou-kaku3)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
))))))))))))))))))))))))))))))
(provide "survey-01")
;;-----------------------------------------------------------------------------
;; calc/survey-02.scm
(define-module survey-02
(export habagui-chokusen-calc))
(select-module survey-02)
(add-load-path ".")
(use surveymod)
(use math.const)
(define (habagui-chokusen-calc)
(newline)
(let loop0 ((count 1))
(print "幅杭計算(直線)")
(newline)
(let loop-01 ((count 1))
(print "幅Ｌ")
(let ((haba-L (read)))
(if (not (real? haba-L))
(begin (newline)
(print "幅Ｌを入力してください")
(newline)
(loop-01 (+ count 1)))
(if (negative? haba-L)
(begin (newline)
(print "幅Ｌを入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "幅Ｒ")
(let ((haba-R (read)))
(if (not (real? haba-R))
(begin (newline)
(print "幅Ｒを入力してください")
(newline)
(loop-02 (+ count 1)))
(if (negative? haba-R)
(begin (newline)
(print "幅Ｒを入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop-03 ((count 1))
(print "Ａ点 Ｘ座標")
(let ((Ax (read)))
(if (not (real? Ax))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(let loop-04 ((count 1))
(print "Ａ点 Ｙ座標")
(let ((Ay (read)))
(if (not (real? Ay))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-04 (+ count 1)))
(begin
(let loop-05 ((count 1))
(print "Ｂ点 Ｘ座標")
(let ((Bx (read)))
(if (not (real? Bx))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-05 (+ count 1)))
(begin
(let loop-06 ((count 1))
(print "Ｂ点 Ｙ座標")
(let ((By (read)))
(if (not (real? By))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-06 (+ count 1)))
(begin
(let loop1 ((count 1))
(let loop-07 ((count 1))
(print "Ａ点からＰ点までの距離")
(let ((Lp (read)))
(if (not (real? Lp))
(begin (newline)
(print "距離を入力してください")
(newline)
(loop-07 (+ count 1)))
(if (negative? Lp)
(begin (newline)
(print "距離を入力してください")
(newline)
(loop-07 (+ count 1)))
(begin
(let* (
(houkou-kaku1
(* (atan (- By Ay) (- Bx Ax)) 180/pi))
(houkou-kaku2 (add360 houkou-kaku1))
(houkou-kaku3 (- houkou-kaku2 90))
(houkou-kaku4 (add360 houkou-kaku3))
(houkou-kaku5 (- houkou-kaku2 270))
(houkou-kaku6 (add360 houkou-kaku5))
(Px1 (* Lp (cos (* houkou-kaku2 pi/180))))
(Px2 (+ Ax Px1))
(Py1 (* Lp (sin (* houkou-kaku2 pi/180))))
(Py2 (+ Ay Py1))
(PLx1 (* haba-L (cos (* houkou-kaku4 pi/180))))
(PLx2 (+ Px2 PLx1))
(PLy1 (* haba-L (sin (* houkou-kaku4 pi/180))))
(PLy2 (+ Py2 PLy1))
(PRx1 (* haba-R (cos (* houkou-kaku6 pi/180))))
(PRx2 (+ Px2 PRx1))
(PRy1 (* haba-R (sin (* houkou-kaku6 pi/180))))
(PRy2 (+ Py2 PRy1))
(Px3 (addtail Px2))
(Py3 (addtail Py2))
(PLx3 (addtail PLx2))
(PLy3 (addtail PLy2))
(PRx3 (addtail PRx2))
(PRy3 (addtail PRy2))
)
(newline)
(print "Ｐ点 Ｘ座標 " Px3)
(print "Ｐ点 Ｙ座標 " Py3)
(newline)
(print "ＰＬ点 Ｘ座標 " PLx3)
(print "ＰＬ点 Ｙ座標 " PLy3)
(newline)
(print "ＰＲ点 Ｘ座標 " PRx3)
(print "ＰＲ点 Ｙ座標 " PRy3)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
)))))))))))))))))))))))))))))))))))))
(provide "survey-02")
;;-----------------------------------------------------------------------------
;; calc/survey-03.scm
(define-module survey-03
(export habagui-kyokusen-calc))
(select-module survey-03)
(add-load-path ".")
(use surveymod)
(use math.const)
(define (habagui-kyokusen-calc)
(newline)
(print "幅杭計算(曲線)")
(newline)
(print "左カーブ(1) 右カーブ(2)")
(let ((curve (read)))
(newline)
(case curve
((1) (begin
(let loop0 ((count 1))
(print "幅杭計算(曲線) 左カーブ")
(newline)
(let loop-01 ((count 1))
(print "幅Ｌ")
(let ((haba-L (read)))
(if (not (real? haba-L))
(begin (newline)
(print "幅Ｌを入力してください")
(newline)
(loop-01 (+ count 1)))
(if (negative? haba-L)
(begin (newline)
(print "幅Ｌを入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "幅Ｒ")
(let ((haba-R (read)))
(if (not (real? haba-R))
(begin (newline)
(print "幅Ｒを入力してください")
(newline)
(loop-02 (+ count 1)))
(if (negative? haba-R)
(begin (newline)
(print "幅Ｒを入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop-03 ((count 1))
(print "半径")
(let ((hankei (read)))
(if (not (real? hankei))
(begin (newline)
(print "半径を入力してください")
(newline)
(loop-03 (+ count 1)))
(if (not (positive? hankei))
(begin (newline)
(print "半径を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(let loop-04 ((count 1))
(print "ＢＣ点 Ｘ座標")
(let ((BC-x (read)))
(if (not (real? BC-x))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-04 (+ count 1)))
(begin
(let loop-05 ((count 1))
(print "ＢＣ点 Ｙ座標")
(let ((BC-y (read)))
(if (not (real? BC-y))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-05 (+ count 1)))
(begin
(let loop-06 ((count 1))
(print "ＩＰ点 Ｘ座標")
(let ((IP-x (read)))
(if (not (real? IP-x))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-06 (+ count 1)))
(begin
(let loop-07 ((count 1))
(print "ＩＰ点 Ｙ座標")
(let ((IP-y (read)))
(if (not (real? IP-y))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-07 (+ count 1)))
(begin
(let loop1 ((count 1))
(let loop-08 ((count 1))
(print "ＢＣ点からＰ点までの弧長")
(let ((kochou (read)))
(if (not (real? kochou))
(begin (newline)
(print "弧長を入力してください")
(newline)
(loop-08 (+ count 1)))
(if (negative? kochou)
(begin (newline)
(print "弧長を入力してください")
(newline)
(loop-08 (+ count 1)))
(begin
(let* (
(houkou-kaku-A1
(* (atan (- IP-y BC-y) (- IP-x BC-x)) 180/pi))
(houkou-kaku-A2
(add360 houkou-kaku-A1))
(houkou-kaku-B1
(- houkou-kaku-A2 90))
(houkou-kaku-B2
(add360 houkou-kaku-B1))
(chuushin-x1
(* hankei (cos (* houkou-kaku-B2 pi/180))))
(chuushin-x2
(+ BC-x chuushin-x1))
(chuushin-y1
(* hankei (sin (* houkou-kaku-B2 pi/180))))
(chuushin-y2
(+ BC-y chuushin-y1))
(henkaku1 (* (/. kochou hankei) (/. 180/pi 2)))
(genchou1 (* (* 2 hankei) (sin (* henkaku1 pi/180))))
(gen-houkou-kaku-C1
(- houkou-kaku-A2 henkaku1))
(gen-houkou-kaku-C2
(add360 gen-houkou-kaku-C1))
(Px1 (* genchou1 (cos (* gen-houkou-kaku-C2 pi/180))))
(Px2 (+ BC-x Px1))
(Py1 (* genchou1 (sin (* gen-houkou-kaku-C2 pi/180))))
(Py2 (+ BC-y Py1))
(houkou-kaku-D1
(* (atan (- Py2 chuushin-y2) (- Px2 chuushin-x2))
180/pi))
(houkou-kaku-D2
(add360 houkou-kaku-D1))
(PRx1 (* haba-R (cos (* houkou-kaku-D2 pi/180))))
(PRx2 (+ Px2 PRx1))
(PRy1 (* haba-R (sin (* houkou-kaku-D2 pi/180))))
(PRy2 (+ Py2 PRy1))
(houkou-kaku-E1
(+ houkou-kaku-D2 180))
(houkou-kaku-E2
(cut360 houkou-kaku-E1))
(PLx1 (* haba-L (cos (* houkou-kaku-E2 pi/180))))
(PLx2 (+ Px2 PLx1))
(PLy1 (* haba-L (sin (* houkou-kaku-E2 pi/180))))
(PLy2 (+ Py2 PLy1))
(Px3 (addtail Px2))
(Py3 (addtail Py2))
(PRx3 (addtail PRx2))
(PRy3 (addtail PRy2))
(PLx3 (addtail PLx2))
(PLy3 (addtail PLy2))
)
(newline)
(print "Ｐ点 Ｘ座標 " Px3)
(print "Ｐ点 Ｙ座標 " Py3)
(newline)
(print "ＰＬ点 Ｘ座標 " PLx3)
(print "ＰＬ点 Ｙ座標 " PLy3)
(newline)
(print "ＰＲ点 Ｘ座標 " PRx3)
(print "ＰＲ点 Ｙ座標 " PRy3)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
)))))))))))))))))))))))))))))))))))))))))))
((2) (begin
(let loop0 ((count 1))
(print "幅杭計算(曲線) 右カーブ")
(newline)
(let loop-01 ((count 1))
(print "幅Ｌ")
(let ((haba-L (read)))
(if (not (real? haba-L))
(begin (newline)
(print "幅Ｌを入力してください")
(newline)
(loop-01 (+ count 1)))
(if (negative? haba-L)
(begin (newline)
(print "幅Ｌを入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "幅Ｒ")
(let ((haba-R (read)))
(if (not (real? haba-R))
(begin (newline)
(print "幅Ｒを入力してください")
(newline)
(loop-02 (+ count 1)))
(if (negative? haba-R)
(begin (newline)
(print "幅Ｒを入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop-03 ((count 1))
(print "半径")
(let ((hankei (read)))
(if (not (real? hankei))
(begin (newline)
(print "半径を入力してください")
(newline)
(loop-03 (+ count 1)))
(if (not (positive? hankei))
(begin (newline)
(print "半径を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(let loop-04 ((count 1))
(print "ＢＣ点 Ｘ座標")
(let ((BC-x (read)))
(if (not (real? BC-x))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-04 (+ count 1)))
(begin
(let loop-05 ((count 1))
(print "ＢＣ点 Ｙ座標")
(let ((BC-y (read)))
(if (not (real? BC-y))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-05 (+ count 1)))
(begin
(let loop-06 ((count 1))
(print "ＩＰ点 Ｘ座標")
(let ((IP-x (read)))
(if (not (real? IP-x))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-06 (+ count 1)))
(begin
(let loop-07 ((count 1))
(print "ＩＰ点 Ｙ座標")
(let ((IP-y (read)))
(if (not (real? IP-y))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-07 (+ count 1)))
(begin
(let loop1 ((count 1))
(let loop-08 ((count 1))
(print "ＢＣ点からＰ点までの弧長")
(let ((kochou (read)))
(if (not (real? kochou))
(begin (newline)
(print "弧長を入力してください")
(newline)
(loop-08 (+ count 1)))
(if (negative? kochou)
(begin (newline)
(print "弧長を入力してください")
(newline)
(loop-08 (+ count 1)))
(begin
(let* (
(houkou-kaku-A1
(* (atan (- IP-y BC-y) (- IP-x BC-x)) 180/pi))
(houkou-kaku-A2
(add360 houkou-kaku-A1))
(houkou-kaku-B1
(+ houkou-kaku-A2 90))
(houkou-kaku-B2
(cut360 houkou-kaku-B1))
(chuushin-x1
(* hankei (cos (* houkou-kaku-B2 pi/180))))
(chuushin-x2
(+ BC-x chuushin-x1))
(chuushin-y1
(* hankei (sin (* houkou-kaku-B2 pi/180))))
(chuushin-y2
(+ BC-y chuushin-y1))
(henkaku1 (* (/. kochou hankei) (/. 180/pi 2)))
(genchou1 (* (* 2 hankei) (sin (* henkaku1 pi/180))))
(gen-houkou-kaku-C1
(+ houkou-kaku-A2 henkaku1))
(gen-houkou-kaku-C2
(cut360 gen-houkou-kaku-C1))
(Px1 (* genchou1 (cos (* gen-houkou-kaku-C2 pi/180))))
(Px2 (+ BC-x Px1))
(Py1 (* genchou1 (sin (* gen-houkou-kaku-C2 pi/180))))
(Py2 (+ BC-y Py1))
(houkou-kaku-D1
(* (atan (- Py2 chuushin-y2) (- Px2 chuushin-x2))
180/pi))
(houkou-kaku-D2
(add360 houkou-kaku-D1))
(PLx1 (* haba-L (cos (* houkou-kaku-D2 pi/180))))
(PLx2 (+ Px2 PLx1))
(PLy1 (* haba-L (sin (* houkou-kaku-D2 pi/180))))
(PLy2 (+ Py2 PLy1))
(houkou-kaku-E1
(+ houkou-kaku-D2 180))
(houkou-kaku-E2
(cut360 houkou-kaku-E1))
(PRx1 (* haba-R (cos (* houkou-kaku-E2 pi/180))))
(PRx2 (+ Px2 PRx1))
(PRy1 (* haba-R (sin (* houkou-kaku-E2 pi/180))))
(PRy2 (+ Py2 PRy1))
(Px3 (addtail Px2))
(Py3 (addtail Py2))
(PLx3 (addtail PLx2))
(PLy3 (addtail PLy2))
(PRx3 (addtail PRx2))
(PRy3 (addtail PRy2))
)
(newline)
(print "Ｐ点 Ｘ座標 " Px3)
(print "Ｐ点 Ｙ座標 " Py3)
(newline)
(print "ＰＬ点 Ｘ座標 " PLx3)
(print "ＰＬ点 Ｙ座標 " PLy3)
(newline)
(print "ＰＲ点 Ｘ座標 " PRx3)
(print "ＰＲ点 Ｙ座標 " PRy3)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
)))))))))))))))))))))))))))))))))))))))))))
)))
(provide "survey-03")
;;-----------------------------------------------------------------------------
;; calc/survey-04.scm
(define-module survey-04
(export suisen-calc))
(select-module survey-04)
(add-load-path ".")
(use surveymod)
(use math.const)
(define (suisen-calc)
(newline)
(print "垂線計算 １点１方向角(1) ２点(2)")
(let ((keisan-houhou (read))) (newline)
(case keisan-houhou
((1) (begin
(let loop0 ((count 1))
(print "垂線計算 １点１方向角")
(newline)
(let loop-01 ((count 1))
(print "Ａ点 Ｘ座標")
(let ((Ax (read)))
(if (not (real? Ax))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "Ａ点 Ｙ座標")
(let ((Ay (read)))
(if (not (real? Ay))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop-03 ((count 1))
(print "Ａ点 方向角 0-00-00 から 359-59-59")
(let ((houkou-kaku (read))) (newline)
(if (not (degrees360? houkou-kaku))
(begin (newline)
(print "方向角を入力してください")
(newline))
(begin
(let loop1 ((count 1))
(let loop-04 ((count 1))
(print "Ｃ点 Ｘ座標")
(let ((Cx (read)))
(if (not (real? Cx))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-04 (+ count 1)))
(begin
(let loop-05 ((count 1))
(print "Ｃ点 Ｙ座標")
(let ((Cy (read)))
(if (not (real? Cy))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-05 (+ count 1)))
(begin
(let* (
(houkou-kaku1 (convert60->10 houkou-kaku))
(m1 (tan (* pi/180 houkou-kaku1)))
(m2 (tan (* pi/180 (add360 (- houkou-kaku1 90)))))
(Px1 (/. (- (+ (- (* m2 Cx) (* m1 Ax)) Ay) Cy) (- m2 m1)))
(Py1 (+ (* m1 (- Px1 Ax)) Ay))
(Lc1 (sqrt (+ (expt (- Cx Px1) 2) (expt (- Cy Py1) 2))))
(Px2 (addtail Px1))
(Py2 (addtail Py1))
(Lc2 (addtail Lc1))
)
(newline)
(print "Ｐ点 Ｘ座標 " Px2)
(print "Ｐ点 Ｙ座標 " Py2)
(print "垂線長 " Lc2)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
)))))))))))))))))))))))))))
((2) (begin
(let loop0 ((count 1))
(print "垂線計算 ２点")
(newline)
(let loop-01 ((count 1))
(print "Ａ点 Ｘ座標")
(let ((Ax (read)))
(if (not (real? Ax))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "Ａ点 Ｙ座標")
(let ((Ay (read)))
(if (not (real? Ay))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop-03 ((count 1))
(print "Ｂ点 Ｘ座標")
(let ((Bx (read)))
(if (not (real? Bx))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(let loop-04 ((count 1))
(print "Ｂ点 Ｙ座標")
(let ((By (read))) (newline)
(if (not (real? By))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-04 (+ count 1)))
(begin
(let loop1 ((count 1))
(let loop-05 ((count 1))
(print "Ｃ点 Ｘ座標")
(let ((Cx (read)))
(if (not (real? Cx))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-05 (+ count 1)))
(begin
(let loop-06 ((count 1))
(print "Ｃ点 Ｙ座標")
(let ((Cy (read)))
(if (not (real? Cy))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-06 (+ count 1)))
(begin
(let* (
(ABx (- Bx Ax))
(ABy (- By Ay))
(m1 (tan (* pi/180 (* 180/pi (atan ABy ABx)))))
(m2 (tan (* pi/180 (add360 (- (* 180/pi (atan ABy ABx)) 90)))))
(Px1 (/. (- (+ (- (* m2 Cx) (* m1 Ax)) Ay) Cy) (- m2 m1)))
(Py1 (+ (* m1 (- Px1 Ax)) Ay))
(Lc1 (sqrt (+ (expt (- Cx Px1) 2) (expt (- Cy Py1) 2))))
(Px2 (addtail Px1))
(Py2 (addtail Py1))
(Lc2 (addtail Lc1))
)
(newline)
(print "Ｐ点 Ｘ座標 " Px2)
(print "Ｐ点 Ｙ座標 " Py2)
(print "垂線長 " Lc2)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
)))))))))))))))))))))))))))))))
)))
(provide "survey-04")
;;-----------------------------------------------------------------------------
;; calc/survey-05.scm
(define-module survey-05
(export kouten-calc))
(select-module survey-05)
(add-load-path ".")
(use surveymod)
(use math.const)
(define (kouten-calc)
(newline)
(print "交点計算 ２点２方向角(1) ４点(2)")
(let ((keisan-houhou (read))) (newline)
(case keisan-houhou
((1) (begin
(let loop0 ((count 1))
(print "交点計算 ２点２方向角")
(newline)
(let loop-01 ((count 1))
(print "Ａ１点 Ｘ座標")
(let ((A1x (read)))
(if (not (real? A1x))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "Ａ１点 Ｙ座標")
(let ((A1y (read)))
(if (not (real? A1y))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop-03 ((count 1))
(print "Ａ１点 方向角 0-00-00 から 359-59-59")
(let ((A1-houkou-kaku (read))) (newline)
(if (not (degrees360? A1-houkou-kaku))
(begin (newline)
(print "方向角を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(let loop1 ((count 1))
(let loop-04 ((count 1))
(print "Ｂ１点 Ｘ座標")
(let ((B1x (read)))
(if (not (real? B1x))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-04 (+count 1)))
(begin
(let loop-05 ((count 1))
(print"Ｂ１点 Ｙ座標")
(let ((B1y (read)))
(if (not (real? B1y))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-05 (+ count 1)))
(begin
(let loop-06 ((count 1))
(print "Ｂ１点 方向角 0-00-00 から 359-59-59")
(let ((B1-houkou-kaku (read)))
(if (not (degrees360? B1-houkou-kaku))
(begin (newline)
(print "方向角を入力してください")
(newline)
(loop-06 (+ count 1)))
(begin
(let (
(A1-houkou-kaku1 (convert60->10 A1-houkou-kaku))
(B1-houkou-kaku1 (convert60->10 B1-houkou-kaku))
)
(if
(or
(<= 180.0 (- A1-houkou-kaku1 B1-houkou-kaku1) 180.00000000000006)
(<= 180.0 (- B1-houkou-kaku1 A1-houkou-kaku1) 180.00000000000006)
(= 0.0 (- A1-houkou-kaku1 B1-houkou-kaku1))
(= 0.0 (- B1-houkou-kaku1 A1-houkou-kaku1))
)
(begin (newline)
(print "交点がありません")
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
(else (begin (newline) (print "計算終了") (newline))))))
(begin
(let* (
(m1 (tan (* pi/180 A1-houkou-kaku1)))
(m2 (tan (* pi/180 B1-houkou-kaku1)))
(X (/. (- (+ (- (* m2 B1x) (* m1 A1x)) A1y) B1y) (- m2 m1)))
(Y (+ (* m1 (- X A1x)) A1y))
(X1 (addtail X))
(Y1 (addtail Y))
)
(newline)
(print "Ｐ点 Ｘ座標 " X1)
(print "Ｐ点 Ｙ座標 " Y1)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
))))))))))))))))))))))))))))))))))
((2) (begin
(let loop0 ((count 1))
(print "交点計算 ４点")
(newline)
(let loop-01 ((count 1))
(print "Ａ１点 Ｘ座標")
(let ((A1x (read)))
(if (not (real? A1x))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "Ａ１点 Ｙ座標")
(let ((A1y (read))) (newline)
(if (not (real? A1y))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop-03 ((count 1))
(print "Ａ２点 Ｘ座標")
(let ((A2x (read)))
(if (not (real? A2x))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(let loop-04 ((count 1))
(print "Ａ２点 Ｙ座標")
(let ((A2y (read))) (newline)
(if (not (real? A2y))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-04 (+ count 1)))
(begin
(let loop1 ((count 1))
(let loop-05 ((count 1))
(print"Ｂ１点 Ｘ座標")
(let ((B1x (read)))
(if (not (real? B1x))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-05 (+ count 1)))
(begin
(let loop-06 ((count 1))
(print "Ｂ１点 Ｙ座標")
(let ((B1y (read))) (newline)
(if (not (real? B1y))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-06 (+ count 1)))
(begin
(let loop-07 ((count 1))
(print "Ｂ２点 Ｘ座標")
(let ((B2x (read)))
(if (not (real? B2x))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-07 (+ count 1)))
(begin
(let loop-08 ((count 1))
(print "Ｂ２点 Ｙ座標")
(let ((B2y (read)))
(if (not (real? B2y))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-08 (+ count 1)))
(begin
(let* (
(a-x (- A2x A1x))
(a-y (- A2y A1y))
(b-x (- B2x B1x))
(b-y (- B2y B1y))
(m01 (add360 (* 180/pi (atan a-y a-x))))
(m02 (add360 (* 180/pi (atan b-y b-x))))
)
(if
(or
(<= 180.0 (- m01 m02) 180.00000000000006)
(<= 180.0 (- m02 m01) 180.00000000000006)
(= 0.0 (- m01 m02))
(= 0.0 (- m02 m01))
)
(begin (newline)
(print "交点がありません")
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline))))))
(begin
(let* (
(m1 (tan (* pi/180 m01)))
(m2 (tan (* pi/180 m02)))
(X (/. (- (+ (- (* m2 B1x) (* m1 A1x)) A1y) B1y) (- m2 m1)))
(Y (+ (* m1 (- X A1x)) A1y))
(X1 (addtail X))
(Y1 (addtail Y))
)
(newline)
(print "Ｐ点 Ｘ座標 " X1)
(print "Ｐ点 Ｙ座標 " Y1)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
))))))))))))))))))))))))))))))))))))))))))
)))
(provide "survey-05")
;;-----------------------------------------------------------------------------
;; calc/survey-06.scm
(define-module survey-06
(export kouten-en-chokusen-calc))
(select-module survey-06)
(add-load-path ".")
(use surveymod)
(use math.const)
(define (kouten-en-chokusen-calc)
(newline)
(print "交点計算(円・直線) １点１方向角(1) ２点(2)")
(let ((keisan-houhou (read))) (newline)
(case keisan-houhou
((1) (begin
(let loop0 ((count 1))
(print "交点計算(円・直線) １点１方向角")
(newline)
(let loop-01 ((count 1))
(print "円の中心 Ｘ座標")
(let ((Xo (read)))
(if (not (real? Xo))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "円の中心 Ｙ座標")
(let ((Yo (read)))
(if (not (real? Yo))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop-03 ((count 1))
(print "円の半径")
(let ((R (read))) (newline)
(if (not (real? R))
(begin (newline)
(print "半径を入力してください")
(newline)
(loop-03 (+ count 1)))
(if (not (positive? R))
(begin (newline)
(print "半径を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(let loop1 ((count 1))
(let loop-04 ((count 1))
(print "Ａ点 Ｘ座標")
(let ((Ax (read)))
(if (not (real? Ax))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-04 (+ count 1)))
(begin
(let loop-05 ((count 1))
(print "Ａ点 Ｙ座標")
(let ((Ay (read)))
(if (not (real? Ay))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-05 (+ count 1)))
(begin
(let loop-06 ((count 1))
(print "Ａ点 方向角 0-00-00 から 359-59-59")
(let ((houkou-kaku (read)))
(if (not (degrees360? houkou-kaku))
(begin (newline)
(print "方向角を入力してください")
(newline)
(loop-06 (+ count 1)))
(begin
(let* (
(X (- Ax Xo))
(Y (- Ay Yo))
(houkou-kaku1 (convert60->10 houkou-kaku))
(m (tan (* pi/180 houkou-kaku1)))
(n (- (* X m) Y))
(l (sqrt (- (* (expt R 2) (+ (expt m 2) 1)) (expt n 2))))
)
(if (or (= 90.0 houkou-kaku1) (= 270.0 houkou-kaku1))
(begin
(let* (
(Px1 (+ Ax 0))
(Py1 (+ Yo (sqrt (- (expt R 2) (expt X 2)))))
(Qx1 (+ Ax 0))
(Qy1 (- Yo (sqrt (- (expt R 2) (expt X 2)))))
)
(if (or
(not (real? Px1))
(not (real? Py1))
(not (real? Qx1))
(not (real? Qy1))
)
(begin (newline)
(print "交点がありません")
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline))))))
(begin
(let* (
(Px2 (addtail Px1))
(Py2 (addtail Py1))
(Qx2 (addtail Qx1))
(Qy2 (addtail Qy1))
)
(newline)
(print "Ｐ点 Ｘ座標 " Px2)
(print "Ｐ点 Ｙ座標 " Py2)
(newline)
(print "Ｑ点 Ｘ座標 " Qx2)
(print "Ｑ点 Ｙ座標 " Qy2)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline))))))))))
(begin
(let* (
(Px1 (+ (/. (+ (* m n) l)
(+ (expt m 2) 1)) Xo))
(Py1 (+ (- (* (/. (+ (* m n ) l)
(+ (expt m 2) 1)) m) n) Yo))
(Qx1 (+ (/. (- (* m n) l)
(+ (expt m 2) 1)) Xo))
(Qy1 (+ (- (* (/. (- (* m n ) l)
(+ (expt m 2) 1)) m) n) Yo))
)
(if (or
(not (real? Px1))
(not (real? Py1))
(not (real? Qx1))
(not (real? Qy1))
)
(begin (newline)
(print "交点がありません")
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline))))))
(begin
(let* (
(Px2 (addtail Px1))
(Py2 (addtail Py1))
(Qx2 (addtail Qx1))
(Qy2 (addtail Qy1))
)
(newline)
(print "Ｐ点 Ｘ座標 " Px2)
(print "Ｐ点 Ｙ座標 " Py2)
(newline)
(print "Ｑ点 Ｘ座標 " Qx2)
(print "Ｑ点 Ｙ座標 " Qy2)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
))))))))))))))))))))))))))))))))))))))
((2) (begin
(let loop0 ((count 1))
(print "交点計算(円・直線) ２点")
(newline)
(let loop-01 ((count 1))
(print "円の中心 Ｘ座標")
(let ((Xo (read)))
(if (not (real? Xo))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "円の中心 Ｙ座標")
(let ((Yo (read)))
(if (not (real? Yo))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop-03 ((count 1))
(print "円の半径")
(let ((R (read))) (newline)
(if (not (real? R))
(begin (newline)
(print "半径を入力してください")
(newline)
(loop-03 (+ count 1)))
(if (not (positive? R))
(begin (newline)
(print "半径を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(let loop1 ((count 1))
(let loop-04 ((count 1))
(print "Ａ点 Ｘ座標")
(let ((Ax (read)))
(if (not (real? Ax))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-04 (+ count 1)))
(begin
(let loop-05 ((count 1))
(print "Ａ点 Ｙ座標")
(let ((Ay (read)))
(if (not (real? Ay))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-05 (+ count 1)))
(begin
(let loop-06 ((count 1))
(print "Ｂ点 Ｘ座標")
(let ((Bx (read)))
(if (not (real? Bx))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-06 (+ count 1)))
(begin
(let loop-07 ((count 1))
(print "Ｂ点 Ｙ座標")
(let ((By (read)))
(if (not (real? By))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-07 (+ count 1)))
(begin
(let* (
(X (- Ax Xo))
(Y (- Ay Yo))
(a-x (- Bx Ax))
(a-y (- By Ay))
(m0 (add360 (* 180/pi (atan a-y a-x))))
(m (tan (* pi/180 m0)))
(n (- (* X m) Y))
(l (sqrt (- (* (expt R 2) (+ (expt m 2) 1)) (expt n 2))))
)
(if (or (= 90.0 m0) (= 270.0 m0))
(begin
(let* (
(Px1 (+ Ax 0))
(Py1 (+ Yo (sqrt (- (expt R 2) (expt X 2)))))
(Qx1 (+ Ax 0))
(Qy1 (- Yo (sqrt (- (expt R 2) (expt X 2)))))
)
(if (or
(not (real? Px1))
(not (real? Py1))
(not (real? Qx1))
(not (real? Qy1))
)
(begin (newline)
(print "交点がありません")
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline))))))
(begin
(let* (
(Px2 (addtail Px1))
(Py2 (addtail Py1))
(Qx2 (addtail Qx1))
(Qy2 (addtail Qy1))
)
(newline)
(print "Ｐ点 Ｘ座標 " Px2)
(print "Ｐ点 Ｙ座標 " Py2)
(newline)
(print "Ｑ点 Ｘ座標 " Qx2)
(print "Ｑ点 Ｙ座標 " Qy2)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline))))))))))
(begin
(let* (
(Px1 (+ (/. (+ (* m n) l)
(+ (expt m 2) 1)) Xo))
(Py1 (+ (- (* (/. (+ (* m n ) l)
(+ (expt m 2) 1)) m) n) Yo))
(Qx1 (+ (/. (- (* m n) l)
(+ (expt m 2) 1)) Xo))
(Qy1 (+ (- (* (/. (- (* m n ) l)
(+ (expt m 2) 1)) m) n) Yo))
)
(if (or
(not (real? Px1))
(not (real? Py1))
(not (real? Qx1))
(not (real? Qy1))
)
(begin (newline)
(print "交点がありません")
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline))))))
(begin
(let* (
(Px2 (addtail Px1))
(Py2 (addtail Py1))
(Qx2 (addtail Qx1))
(Qy2 (addtail Qy1))
)
(newline)
(print "Ｐ点 Ｘ座標 " Px2)
(print "Ｐ点 Ｙ座標 " Py2)
(newline)
(print "Ｑ点 Ｘ座標 " Qx2)
(print "Ｑ点 Ｙ座標 " Qy2)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
))))))))))))))))))))))))))))))))))))))))))
)))
(provide "survey-06")
;;-----------------------------------------------------------------------------
;; calc/survey-07.scm
(define-module survey-07
(export kouten-en-en-calc))
(select-module survey-07)
(add-load-path ".")
(use surveymod)
(use math.const)
(define (kouten-en-en-calc)
(newline)
(let loop0 ((count 1))
(print "交点計算(円・円)")
(newline)
(let loop-01 ((count 1))
(print "円Ａの中心 Ｘ座標")
(let ((Ax (read)))
(if (not (real? Ax))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "円Ａの中心 Ｙ座標")
(let ((Ay (read)))
(if (not (real? Ay))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop-03 ((count 1))
(print "円Ａの半径")
(let ((Ra (read))) (newline)
(if (not (real? Ra))
(begin (newline)
(print "半径を入力してください")
(newline)
(loop-03 (+ count 1)))
(if (not (positive? Ra))
(begin (newline)
(print "半径を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(let loop1 ((count 1))
(let loop-04 ((count 1))
(print "円Ｂの中心 Ｘ座標")
(let ((Bx (read)))
(if (not (real? Bx))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-04 (+ count 1)))
(begin
(let loop-05 ((count 1))
(print "円Ｂの中心 Ｙ座標")
(let ((By (read)))
(if (not (real? By))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-05 (+ count 1)))
(begin
(let loop-06 ((count 1))
(print "円Ｂの半径")
(let ((Rb (read)))
(if (not (real? Rb))
(begin (newline)
(print "半径を入力してください")
(newline)
(loop-06 (+ count 1)))
(if (not (positive? Rb))
(begin (newline)
(print "半径を入力してください")
(newline)
(loop-06 (+ count 1)))
(begin
(let* (
(L (sqrt (+ (expt (- By Ay) 2) (expt (- Bx Ax) 2))))
(a1 (* (acos
(/.
(- (+ (expt L 2) (expt Ra 2)) (expt Rb 2))
(* 2 L Ra)
)
) 180/pi))
)
(if (or (not (real? a1)) (not (real? L)))
(begin (newline)
(print "交点がありません")
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
(else (begin (newline) (print "計算終了") (newline))))))
(begin
(let* (
(chuushin-houkou-kaku1
(* (atan (- By Ay) (- Bx Ax)) 180/pi))
(chuushin-houkou-kaku2
(add360 chuushin-houkou-kaku1))
(Px1 (+ Ax (* Ra (cos (*
(cut360 (+ chuushin-houkou-kaku2 a1)) pi/180)))))
(Py1 (+ Ay (* Ra (sin (*
(cut360 (+ chuushin-houkou-kaku2 a1)) pi/180)))))
(Qx1 (+ Ax (* Ra (cos (*
(add360 (- chuushin-houkou-kaku2 a1)) pi/180)))))
(Qy1 (+ Ay (* Ra (sin (*
(add360 (- chuushin-houkou-kaku2 a1)) pi/180)))))
(Px2 (addtail Px1))
(Py2 (addtail Py1))
(Qx2 (addtail Qx1))
(Qy2 (addtail Qy1))
)
(newline)
(print "Ｐ点 Ｘ座標 " Px2)
(print "Ｐ点 Ｙ座標 " Py2)
(newline)
(print "Ｑ点 Ｘ座標 " Qx2)
(print "Ｑ点 Ｙ座標 " Qy2)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
)))))))))))))))))))))))))))))))))))
(provide "survey-07")
;;-----------------------------------------------------------------------------
;; calc/survey-08.scm
(define-module survey-08
(export jyuudankyokusen-calc))
(select-module survey-08)
(add-load-path ".")
(use surveymod)
;(use math.const)
(define (jyuudankyokusen-calc)
(newline)
(print "縦断曲線計算 山型(1) 谷型(2)")
(let ((keisan-houhou (read)))
(newline)
(case keisan-houhou
((1) (begin
(let loop0 ((count 1))
(print "縦断曲線計算 山型")
(newline)
(let loop-01 ((count 1))
(print "縦断曲線始点の計画高")
(let ((shiten-keikakukou (read)))
(if (not (real? shiten-keikakukou))
(begin (newline)
(print "計画高を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "縦断曲線長")
(let ((VCL (read)))
(if (not (real? VCL))
(begin (newline)
(print "縦断曲線長を入力してください")
(newline)
(loop-02 (+ count 1)))
(if (not (positive? VCL))
(begin (newline)
(print "縦断曲線長を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop-03 ((count 1))
(print "勾配１ 上り何％")
(let ((koubai1 (read)))
(if (not (real? koubai1))
(begin (newline)
(print "上り勾配を入力してください")
(newline)
(loop-03 (+ count 1)))
(if (not (positive? koubai1))
(begin (newline)
(print "上り勾配を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(let loop-04 ((count 1))
(print "勾配２ 下り何％")
(let ((koubai2 (read)))
(if (not (real? koubai2))
(begin (newline)
(print "下り勾配を入力してください")
(newline)
(loop-04 (+ count 1)))
(if (not (negative? koubai2))
(begin (newline)
(print "下り勾配を入力してください")
(newline)
(loop-04 (+ count 1)))
(begin
(let loop1 ((count 1))
(let loop-05 ((count 1))
(print "始点からの水平距離")
(let ((suiheikyori (read)))
(if (not (real? suiheikyori))
(begin (newline)
(print "水平距離を入力してください")
(newline)
(loop-05 (+ count 1)))
(if (negative? suiheikyori)
(begin (newline)
(print "水平距離を入力してください")
(newline)
(loop-05 (+ count 1)))
(begin
(let* (
(hyoukousa1 (* suiheikyori (/. koubai1 100)))
(hyoukou1 (+ shiten-keikakukou hyoukousa1))
(Y (* (/. (abs (- koubai1 koubai2))
(* 200 VCL))
(expt suiheikyori 2)))
(keikaku-hyoukou (- hyoukou1 Y))
(keikaku-hyoukou1 (addtail keikaku-hyoukou))
)
(newline)
(print "標高 " hyoukou1)
(print "計画高 " keikaku-hyoukou1)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
)))))))))))))))))))))))))))))))
((2) (begin
(let loop0 ((count 1))
(print "縦断曲線計算 谷型")
(newline)
(let loop-01 ((count 1))
(print "縦断曲線始点の計画高")
(let ((shiten-keikakukou (read)))
(if (not (real? shiten-keikakukou))
(begin (newline)
(print "計画高を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "縦断曲線長")
(let ((VCL (read)))
(if (not (real? VCL))
(begin (newline)
(print "縦断曲線長を入力してください")
(newline)
(loop-02 (+ count 1)))
(if (not (positive? VCL))
(begin (newline)
(print "縦断曲線長を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop-03 ((count 1))
(print "勾配１ 下り何％")
(let ((koubai1 (read)))
(if (not (real? koubai1))
(begin (newline)
(print "下り勾配を入力してください")
(newline)
(loop-03 (+ count 1)))
(if (not (negative? koubai1))
(begin (newline)
(print "下り勾配を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(let loop-04 ((count 1))
(print "勾配２ 上り何％")
(let ((koubai2 (read)))
(if (not (real? koubai2))
(begin (newline)
(print "上り勾配を入力してください")
(newline)
(loop-04 (+ count 1)))
(if (not (positive? koubai2))
(begin (newline)
(print "上り勾配を入力してください")
(newline)
(loop-04 (+ count 1)))
(begin
(let loop1 ((count 1))
(let loop-05 ((count 1))
(print "始点からの水平距離")
(let ((suiheikyori (read)))
(if (not (real? suiheikyori))
(begin (newline)
(print "水平距離を入力してください")
(newline)
(loop-05 (+ count 1)))
(if (negative? suiheikyori)
(begin (newline)
(print "水平距離を入力してください")
(newline)
(loop-05 (+ count 1)))
(begin
(let* (
(hyoukousa1 (* suiheikyori (/. koubai1 100)))
(hyoukou1 (+ shiten-keikakukou hyoukousa1))
(Y (* (/. (abs (- koubai1 koubai2))
(* 200 VCL))
(expt suiheikyori 2)))
(keikaku-hyoukou (+ hyoukou1 Y))
(keikaku-hyoukou1 (addtail keikaku-hyoukou))
)
(newline)
(print "標高 " hyoukou1)
(print "計画高 " keikaku-hyoukou1)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
)))))))))))))))))))))))))))))))
)))
(provide "survey-08")
;;-----------------------------------------------------------------------------
;; calc/survey-09.scm
(define-module survey-09
(export heron-calc))
(select-module survey-09)
(add-load-path ".")
(use surveymod)
;(use math.const)
(define (heron-calc)
(newline)
(print "三辺ヘロン面積計算")
(newline)
(print "ヘロン三角形の数？ (1) から (5)")
(let ((sankakukei (read))) (newline)
(case sankakukei
((1) (begin
(let loop0 ((count 1))
(print "ヘロン三角形の数 1")
(newline)
(print "第１三角形 辺Ａ")
(let ((dai-1-hen-a (read)))
(print "第１三角形 辺Ｂ")
(let ((dai-1-hen-b (read)))
(print "第１三角形 辺Ｃ")
(let ((dai-1-hen-c (read)))
(let* (
(t1 (heron dai-1-hen-a dai-1-hen-b dai-1-hen-c))
(menseki (addtail2 t1))
)
(newline)
(print "面積 " menseki)
(newline)
(print "最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
)))))))))
((2) (begin
(let loop0 ((count 1))
(print "ヘロン三角形の数 2")
(newline)
(print "第１三角形 辺Ａ")
(let ((dai-1-hen-a (read)))
(print "第１三角形 辺Ｂ")
(let ((dai-1-hen-b (read)))
(print "第１三角形 辺Ｃ")
(let ((dai-1-hen-c (read))) (newline)
(print "第２三角形 辺Ａ")
(let ((dai-2-hen-a (read)))
(print "第２三角形 辺Ｂ")
(let ((dai-2-hen-b (read)))
(print "第２三角形 辺Ｃ")
(let ((dai-2-hen-c (read)))
(let* (
(t1 (heron dai-1-hen-a dai-1-hen-b dai-1-hen-c))
(t2 (heron dai-2-hen-a dai-2-hen-b dai-2-hen-c))
(menseki (addtail2 (+ t1 t2)))
)
(newline)
(print "面積 " menseki)
(newline)
(print "最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
))))))))))))
((3) (begin
(let loop0 ((count 1))
(print "ヘロン三角形の数 3")
(newline)
(print "第１三角形 辺Ａ")
(let ((dai-1-hen-a (read)))
(print "第１三角形 辺Ｂ")
(let ((dai-1-hen-b (read)))
(print "第１三角形 辺Ｃ")
(let ((dai-1-hen-c (read))) (newline)
(print "第２三角形 辺Ａ")
(let ((dai-2-hen-a (read)))
(print "第２三角形 辺Ｂ")
(let ((dai-2-hen-b (read)))
(print "第２三角形 辺Ｃ")
(let ((dai-2-hen-c (read))) (newline)
(print "第３三角形 辺Ａ")
(let ((dai-3-hen-a (read)))
(print "第３三角形 辺Ｂ")
(let ((dai-3-hen-b (read)))
(print "第３三角形 辺Ｃ")
(let ((dai-3-hen-c (read)))
(let* (
(t1 (heron dai-1-hen-a dai-1-hen-b dai-1-hen-c))
(t2 (heron dai-2-hen-a dai-2-hen-b dai-2-hen-c))
(t3 (heron dai-3-hen-a dai-3-hen-b dai-3-hen-c))
(menseki (addtail2 (+ t1 t2 t3)))
)
(newline)
(print "面積 " menseki)
(newline)
(print "最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
)))))))))))))))
((4) (begin
(let loop0 ((count 1))
(print "ヘロン三角形の数 4")
(newline)
(print "第１三角形 辺Ａ")
(let ((dai-1-hen-a (read)))
(print "第１三角形 辺Ｂ")
(let ((dai-1-hen-b (read)))
(print "第１三角形 辺Ｃ")
(let ((dai-1-hen-c (read))) (newline)
(print "第２三角形 辺Ａ")
(let ((dai-2-hen-a (read)))
(print "第２三角形 辺Ｂ")
(let ((dai-2-hen-b (read)))
(print "第２三角形 辺Ｃ")
(let ((dai-2-hen-c (read))) (newline)
(print "第３三角形 辺Ａ")
(let ((dai-3-hen-a (read)))
(print "第３三角形 辺Ｂ")
(let ((dai-3-hen-b (read)))
(print "第３三角形 辺Ｃ")
(let ((dai-3-hen-c (read))) (newline)
(print "第４三角形 辺Ａ")
(let ((dai-4-hen-a (read)))
(print "第４三角形 辺Ｂ")
(let ((dai-4-hen-b (read)))
(print "第４三角形 辺Ｃ")
(let ((dai-4-hen-c (read)))
(let* (
(t1 (heron dai-1-hen-a dai-1-hen-b dai-1-hen-c))
(t2 (heron dai-2-hen-a dai-2-hen-b dai-2-hen-c))
(t3 (heron dai-3-hen-a dai-3-hen-b dai-3-hen-c))
(t4 (heron dai-4-hen-a dai-4-hen-b dai-4-hen-c))
(menseki (addtail2 (+ t1 t2 t3 t4)))
)
(newline)
(print "面積 " menseki)
(newline)
(print "最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
))))))))))))))))))
((5) (begin
(let loop0 ((count 1))
(print "ヘロン三角形の数 5")
(newline)
(print "第１三角形 辺Ａ")
(let ((dai-1-hen-a (read)))
(print "第１三角形 辺Ｂ")
(let ((dai-1-hen-b (read)))
(print "第１三角形 辺Ｃ")
(let ((dai-1-hen-c (read))) (newline)
(print "第２三角形 辺Ａ")
(let ((dai-2-hen-a (read)))
(print "第２三角形 辺Ｂ")
(let ((dai-2-hen-b (read)))
(print "第２三角形 辺Ｃ")
(let ((dai-2-hen-c (read))) (newline)
(print "第３三角形 辺Ａ")
(let ((dai-3-hen-a (read)))
(print "第３三角形 辺Ｂ")
(let ((dai-3-hen-b (read)))
(print "第３三角形 辺Ｃ")
(let ((dai-3-hen-c (read))) (newline)
(print "第４三角形 辺Ａ")
(let ((dai-4-hen-a (read)))
(print "第４三角形 辺Ｂ")
(let ((dai-4-hen-b (read)))
(print "第４三角形 辺Ｃ")
(let ((dai-4-hen-c (read))) (newline)
(print "第５三角形 辺Ａ")
(let ((dai-5-hen-a (read)))
(print "第５三角形 辺Ｂ")
(let ((dai-5-hen-b (read)))
(print "第５三角形 辺Ｃ")
(let ((dai-5-hen-c (read)))
(let* (
(t1 (heron dai-1-hen-a dai-1-hen-b dai-1-hen-c))
(t2 (heron dai-2-hen-a dai-2-hen-b dai-2-hen-c))
(t3 (heron dai-3-hen-a dai-3-hen-b dai-3-hen-c))
(t4 (heron dai-4-hen-a dai-4-hen-b dai-4-hen-c))
(t5 (heron dai-5-hen-a dai-5-hen-b dai-5-hen-c))
(menseki (addtail2 (+ t1 t2 t3 t4 t5)))
)
(newline)
(print "面積 " menseki)
(newline)
(print "最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
)))))))))))))))))))))
)))
(provide "survey-09")
;;-----------------------------------------------------------------------------
;; calc/survey-10.scm
(define-module survey-10
(export menseki-calc))
(select-module survey-10)
(add-load-path ".")
(use surveymod)
;(use math.const)
(define (menseki-calc)
(newline)
(print "座標面積計算")
(newline)
(print "何角形？ (3) から (10)")
(let ((nankakukei (read))) (newline)
(case nankakukei
((3) (begin
(let loop0 ((count 1))
(print "三角形")
(newline)
(print "第１点 Ｘ座標")
(let ((dai-1-x (read)))
(print "第１点 Ｙ座標")
(let ((dai-1-y (read))) (newline)
(print "第２点 Ｘ座標")
(let ((dai-2-x (read)))
(print "第２点 Ｙ座標")
(let ((dai-2-y (read))) (newline)
(print "第３点 Ｘ座標")
(let ((dai-3-x (read)))
(print "第３点 Ｙ座標")
(let ((dai-3-y (read)))
(let* (
(wa (/. (abs (+ (* (- dai-2-x dai-1-x) (+ dai-2-y dai-1-y))
(* (- dai-3-x dai-2-x) (+ dai-3-y dai-2-y))
(* (- dai-1-x dai-3-x) (+ dai-1-y dai-3-y))
)
) 2))
(menseki (addtail2 wa))
)
(newline)
(print "面積 " menseki)
(newline)
(print "最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
))))))))))))
((4) (begin
(let loop0 ((count 1))
(print "四角形")
(newline)
(print "第１点 Ｘ座標")
(let ((dai-1-x (read)))
(print "第１点 Ｙ座標")
(let ((dai-1-y (read))) (newline)
(print "第２点 Ｘ座標")
(let ((dai-2-x (read)))
(print "第２点 Ｙ座標")
(let ((dai-2-y (read))) (newline)
(print "第３点 Ｘ座標")
(let ((dai-3-x (read)))
(print "第３点 Ｙ座標")
(let ((dai-3-y (read))) (newline)
(print "第４点 Ｘ座標")
(let ((dai-4-x (read)))
(print "第４点 Ｙ座標")
(let ((dai-4-y (read)))
(let* (
(wa (/. (abs (+ (* (- dai-2-x dai-1-x) (+ dai-2-y dai-1-y))
(* (- dai-3-x dai-2-x) (+ dai-3-y dai-2-y))
(* (- dai-4-x dai-3-x) (+ dai-4-y dai-3-y))
(* (- dai-1-x dai-4-x) (+ dai-1-y dai-4-y))
)
) 2))
(menseki (addtail2 wa))
)
(newline)
(print "面積 " menseki)
(newline)
(print "最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
))))))))))))))
((5) (begin
(let loop0 ((count 1))
(print "五角形")
(newline)
(print "第１点 Ｘ座標")
(let ((dai-1-x (read)))
(print "第１点 Ｙ座標")
(let ((dai-1-y (read))) (newline)
(print "第２点 Ｘ座標")
(let ((dai-2-x (read)))
(print "第２点 Ｙ座標")
(let ((dai-2-y (read))) (newline)
(print "第３点 Ｘ座標")
(let ((dai-3-x (read)))
(print "第３点 Ｙ座標")
(let ((dai-3-y (read))) (newline)
(print "第４点 Ｘ座標")
(let ((dai-4-x (read)))
(print "第４点 Ｙ座標")
(let ((dai-4-y (read))) (newline)
(print "第５点 Ｘ座標")
(let ((dai-5-x (read)))
(print "第５点 Ｙ座標")
(let ((dai-5-y (read)))
(let* (
(wa (/. (abs (+ (* (- dai-2-x dai-1-x) (+ dai-2-y dai-1-y))
(* (- dai-3-x dai-2-x) (+ dai-3-y dai-2-y))
(* (- dai-4-x dai-3-x) (+ dai-4-y dai-3-y))
(* (- dai-5-x dai-4-x) (+ dai-5-y dai-4-y))
(* (- dai-1-x dai-5-x) (+ dai-1-y dai-5-y))
)
) 2))
(menseki (addtail2 wa))
)
(newline)
(print "面積 " menseki)
(newline)
(print "最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
))))))))))))))))
((6) (begin
(let loop0 ((count 1))
(print "六角形")
(newline)
(print "第１点 Ｘ座標")
(let ((dai-1-x (read)))
(print "第１点 Ｙ座標")
(let ((dai-1-y (read))) (newline)
(print "第２点 Ｘ座標")
(let ((dai-2-x (read)))
(print "第２点 Ｙ座標")
(let ((dai-2-y (read))) (newline)
(print "第３点 Ｘ座標")
(let ((dai-3-x (read)))
(print "第３点 Ｙ座標")
(let ((dai-3-y (read))) (newline)
(print "第４点 Ｘ座標")
(let ((dai-4-x (read)))
(print "第４点 Ｙ座標")
(let ((dai-4-y (read))) (newline)
(print "第５点 Ｘ座標")
(let ((dai-5-x (read)))
(print "第５点 Ｙ座標")
(let ((dai-5-y (read))) (newline)
(print "第６点 Ｘ座標")
(let ((dai-6-x (read)))
(print "第６点 Ｙ座標")
(let ((dai-6-y (read)))
(let* (
(wa (/. (abs (+ (* (- dai-2-x dai-1-x) (+ dai-2-y dai-1-y))
(* (- dai-3-x dai-2-x) (+ dai-3-y dai-2-y))
(* (- dai-4-x dai-3-x) (+ dai-4-y dai-3-y))
(* (- dai-5-x dai-4-x) (+ dai-5-y dai-4-y))
(* (- dai-6-x dai-5-x) (+ dai-6-y dai-5-y))
(* (- dai-1-x dai-6-x) (+ dai-1-y dai-6-y))
)
) 2))
(menseki (addtail2 wa))
)
(newline)
(print "面積 " menseki)
(newline)
(print "最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
))))))))))))))))))
((7) (begin
(let loop0 ((count 1))
(print "七角形")
(newline)
(print "第１点 Ｘ座標")
(let ((dai-1-x (read)))
(print "第１点 Ｙ座標")
(let ((dai-1-y (read))) (newline)
(print "第２点 Ｘ座標")
(let ((dai-2-x (read)))
(print "第２点 Ｙ座標")
(let ((dai-2-y (read))) (newline)
(print "第３点 Ｘ座標")
(let ((dai-3-x (read)))
(print "第３点 Ｙ座標")
(let ((dai-3-y (read))) (newline)
(print "第４点 Ｘ座標")
(let ((dai-4-x (read)))
(print "第４点 Ｙ座標")
(let ((dai-4-y (read))) (newline)
(print "第５点 Ｘ座標")
(let ((dai-5-x (read)))
(print "第５点 Ｙ座標")
(let ((dai-5-y (read))) (newline)
(print "第６点 Ｘ座標")
(let ((dai-6-x (read)))
(print "第６点 Ｙ座標")
(let ((dai-6-y (read))) (newline)
(print "第７点 Ｘ座標")
(let ((dai-7-x (read)))
(print "第７点 Ｙ座標")
(let ((dai-7-y (read)))
(let* (
(wa (/. (abs (+ (* (- dai-2-x dai-1-x) (+ dai-2-y dai-1-y))
(* (- dai-3-x dai-2-x) (+ dai-3-y dai-2-y))
(* (- dai-4-x dai-3-x) (+ dai-4-y dai-3-y))
(* (- dai-5-x dai-4-x) (+ dai-5-y dai-4-y))
(* (- dai-6-x dai-5-x) (+ dai-6-y dai-5-y))
(* (- dai-7-x dai-6-x) (+ dai-7-y dai-6-y))
(* (- dai-1-x dai-7-x) (+ dai-1-y dai-7-y))
)
) 2))
(menseki (addtail2 wa))
)
(newline)
(print "面積 " menseki)
(newline)
(print "最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
))))))))))))))))))))
((8) (begin
(let loop0 ((count 1))
(print "八角形")
(newline)
(print "第１点 Ｘ座標")
(let ((dai-1-x (read)))
(print "第１点 Ｙ座標")
(let ((dai-1-y (read))) (newline)
(print "第２点 Ｘ座標")
(let ((dai-2-x (read)))
(print "第２点 Ｙ座標")
(let ((dai-2-y (read))) (newline)
(print "第３点 Ｘ座標")
(let ((dai-3-x (read)))
(print "第３点 Ｙ座標")
(let ((dai-3-y (read))) (newline)
(print "第４点 Ｘ座標")
(let ((dai-4-x (read)))
(print "第４点 Ｙ座標")
(let ((dai-4-y (read))) (newline)
(print "第５点 Ｘ座標")
(let ((dai-5-x (read)))
(print "第５点 Ｙ座標")
(let ((dai-5-y (read))) (newline)
(print "第６点 Ｘ座標")
(let ((dai-6-x (read)))
(print "第６点 Ｙ座標")
(let ((dai-6-y (read))) (newline)
(print "第７点 Ｘ座標")
(let ((dai-7-x (read)))
(print "第７点 Ｙ座標")
(let ((dai-7-y (read))) (newline)
(print "第８点 Ｘ座標")
(let ((dai-8-x (read)))
(print "第８点 Ｙ座標")
(let ((dai-8-y (read)))
(let* (
(wa (/. (abs (+ (* (- dai-2-x dai-1-x) (+ dai-2-y dai-1-y))
(* (- dai-3-x dai-2-x) (+ dai-3-y dai-2-y))
(* (- dai-4-x dai-3-x) (+ dai-4-y dai-3-y))
(* (- dai-5-x dai-4-x) (+ dai-5-y dai-4-y))
(* (- dai-6-x dai-5-x) (+ dai-6-y dai-5-y))
(* (- dai-7-x dai-6-x) (+ dai-7-y dai-6-y))
(* (- dai-8-x dai-7-x) (+ dai-8-y dai-7-y))
(* (- dai-1-x dai-8-x) (+ dai-1-y dai-8-y))
)
) 2))
(menseki (addtail2 wa))
)
(newline)
(print "面積 " menseki)
(newline)
(print "最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
))))))))))))))))))))))
((9) (begin
(let loop0 ((count 1))
(print "九角形")
(newline)
(print "第１点 Ｘ座標")
(let ((dai-1-x (read)))
(print "第１点 Ｙ座標")
(let ((dai-1-y (read))) (newline)
(print "第２点 Ｘ座標")
(let ((dai-2-x (read)))
(print "第２点 Ｙ座標")
(let ((dai-2-y (read))) (newline)
(print "第３点 Ｘ座標")
(let ((dai-3-x (read)))
(print "第３点 Ｙ座標")
(let ((dai-3-y (read))) (newline)
(print "第４点 Ｘ座標")
(let ((dai-4-x (read)))
(print "第４点 Ｙ座標")
(let ((dai-4-y (read))) (newline)
(print "第５点 Ｘ座標")
(let ((dai-5-x (read)))
(print "第５点 Ｙ座標")
(let ((dai-5-y (read))) (newline)
(print "第６点 Ｘ座標")
(let ((dai-6-x (read)))
(print "第６点 Ｙ座標")
(let ((dai-6-y (read))) (newline)
(print "第７点 Ｘ座標")
(let ((dai-7-x (read)))
(print "第７点 Ｙ座標")
(let ((dai-7-y (read))) (newline)
(print "第８点 Ｘ座標")
(let ((dai-8-x (read)))
(print "第８点 Ｙ座標")
(let ((dai-8-y (read))) (newline)
(print "第９点 Ｘ座標")
(let ((dai-9-x (read)))
(print "第９点 Ｙ座標")
(let ((dai-9-y (read)))
(let* (
(wa (/. (abs (+ (* (- dai-2-x dai-1-x) (+ dai-2-y dai-1-y))
(* (- dai-3-x dai-2-x) (+ dai-3-y dai-2-y))
(* (- dai-4-x dai-3-x) (+ dai-4-y dai-3-y))
(* (- dai-5-x dai-4-x) (+ dai-5-y dai-4-y))
(* (- dai-6-x dai-5-x) (+ dai-6-y dai-5-y))
(* (- dai-7-x dai-6-x) (+ dai-7-y dai-6-y))
(* (- dai-8-x dai-7-x) (+ dai-8-y dai-7-y))
(* (- dai-9-x dai-8-x) (+ dai-9-y dai-8-y))
(* (- dai-1-x dai-9-x) (+ dai-1-y dai-9-y))
)
) 2))
(menseki (addtail2 wa))
)
(newline)
(print "面積 " menseki)
(newline)
(print "最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
))))))))))))))))))))))))
((10) (begin
(let loop0 ((count 1))
(print "十角形")
(newline)
(print "第１点 Ｘ座標")
(let ((dai-1-x (read)))
(print "第１点 Ｙ座標")
(let ((dai-1-y (read))) (newline)
(print "第２点 Ｘ座標")
(let ((dai-2-x (read)))
(print "第２点 Ｙ座標")
(let ((dai-2-y (read))) (newline)
(print "第３点 Ｘ座標")
(let ((dai-3-x (read)))
(print "第３点 Ｙ座標")
(let ((dai-3-y (read))) (newline)
(print "第４点 Ｘ座標")
(let ((dai-4-x (read)))
(print "第４点 Ｙ座標")
(let ((dai-4-y (read))) (newline)
(print "第５点 Ｘ座標")
(let ((dai-5-x (read)))
(print "第５点 Ｙ座標")
(let ((dai-5-y (read))) (newline)
(print "第６点 Ｘ座標")
(let ((dai-6-x (read)))
(print "第６点 Ｙ座標")
(let ((dai-6-y (read))) (newline)
(print "第７点 Ｘ座標")
(let ((dai-7-x (read)))
(print "第７点 Ｙ座標")
(let ((dai-7-y (read))) (newline)
(print "第８点 Ｘ座標")
(let ((dai-8-x (read)))
(print "第８点 Ｙ座標")
(let ((dai-8-y (read))) (newline)
(print "第９点 Ｘ座標")
(let ((dai-9-x (read)))
(print "第９点 Ｙ座標")
(let ((dai-9-y (read))) (newline)
(print "第10点 Ｘ座標")
(let ((dai-10-x (read)))
(print "第10点 Ｙ座標")
(let ((dai-10-y (read)))
(let* (
(wa (/. (abs (+ (* (- dai-2-x dai-1-x) (+ dai-2-y dai-1-y))
(* (- dai-3-x dai-2-x) (+ dai-3-y dai-2-y))
(* (- dai-4-x dai-3-x) (+ dai-4-y dai-3-y))
(* (- dai-5-x dai-4-x) (+ dai-5-y dai-4-y))
(* (- dai-6-x dai-5-x) (+ dai-6-y dai-5-y))
(* (- dai-7-x dai-6-x) (+ dai-7-y dai-6-y))
(* (- dai-8-x dai-7-x) (+ dai-8-y dai-7-y))
(* (- dai-9-x dai-8-x) (+ dai-9-y dai-8-y))
(* (- dai-10-x dai-9-x) (+ dai-10-y dai-9-y))
(* (- dai-1-x dai-10-x) (+ dai-1-y dai-10-y))
)
) 2))
(menseki (addtail2 wa))
)
(newline)
(print "面積 " menseki)
(newline)
(print "最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
))))))))))))))))))))))))))
)))
(provide "survey-10")
;;-----------------------------------------------------------------------------
;; calc/survey-11.scm
(define-module survey-11
(export tankyokusen-calc))
(select-module survey-11)
(add-load-path ".")
(use surveymod)
(use math.const)
(define (tankyokusen-calc)
(newline)
(print "単曲線計算")
(newline)
(print "偏角、弦長計算(1) 諸元計算(2)")
(let ((keisan-houhou (read))) (newline)
(case keisan-houhou
((1) (begin
(let loop0 ((count 1))
(print "偏角、弦長計算")
(newline)
(let loop-01 ((count 1))
(print "半径")
(let ((hankei (read)))
(if (not (real? hankei))
(begin (newline)
(print "半径を入力してください")
(newline)
(loop-01 (+ count 1)))
(if (not (positive? hankei))
(begin (newline)
(print "半径を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop1 ((count 1))
(let loop-02 ((count 1))
(print "弧長")
(let ((kochou (read)))
(if (not (real? kochou))
(begin (newline)
(print "弧長を入力してください")
(newline)
(loop-02 (+ count 1)))
(if (negative? kochou)
(begin (newline)
(print "弧長を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let* (
(henkaku1 (* (/. kochou hankei) (/. 180/pi 2)))
(genchou1 (* 2 hankei (sin (* henkaku1 pi/180))))
(henkaku2 (convert10->60 henkaku1))
(genchou2 (addtail genchou1))
)
(newline)
(print "偏角 " henkaku2)
(print "弦長 " genchou2)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
)))))))))))))))))
((2) (begin
(let loop0 ((count 1))
(print "諸元計算")
(newline)
(let loop-01 ((count 1))
(print "半径")
(let ((hankei (read)))
(if (not (real? hankei))
(begin (newline)
(print "半径を入力してください")
(newline)
(loop-01 (+ count 1)))
(if (not (positive? hankei))
(begin (newline)
(print "半径を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop1 ((count 1))
(let loop-02 ((count 1))
(print "交角 0-00-00 から 179-59-59")
(let ((koukaku (read)))
(if (not (degrees180? koukaku))
(begin (newline)
(print "交角を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let* (
(koukaku1 (convert60->10 koukaku))
(sessenchou1 (* hankei (tan (* (/. koukaku1 2) pi/180))))
(kyokusenchou1 (/. (* hankei koukaku1) 180/pi))
(gaiseikatsu1 (* hankei
(-
(/. 1 (cos (* (/. koukaku1 2) pi/180)))
1)))
(genchou1 (* 2 hankei (sin (* (/. koukaku1 2) pi/180))))
(sessenchou2 (addtail sessenchou1))
(kyokusenchou2 (addtail kyokusenchou1))
(gaiseikatsu2 (addtail gaiseikatsu1))
(genchou2 (addtail genchou1))
)
(newline)
(print "接線長(TL) " sessenchou2)
(print "曲線長(CL) " kyokusenchou2)
(print "外正割長(SL) " gaiseikatsu2)
(print "弦長(L) " genchou2)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
))))))))))))))))
)))
(provide "survey-11")
;;-----------------------------------------------------------------------------
;; calc/survey-12.scm
(define-module survey-12
(export sankakukei-calc))
(select-module survey-12)
(add-load-path ".")
(use surveymod)
(use math.const)
(define (sankakukei-calc)
(newline)
(print "三角形の解法")
(print "三辺既知(1) 二辺夾角既知(2) 二角夾辺既知(3)")
(let ((keisan-houhou (read))) (newline)
(case keisan-houhou
((1) (begin
(let loop1 ((count 1))
(print "三辺既知")
(newline)
(let loop-01 ((count 1))
(print "辺Ａ")
(let ((hen-a (read)))
(if (not (real? hen-a))
(begin (newline)
(print "辺長を入力してください")
(newline)
(loop-01 (+ count 1)))
(if (not (positive? hen-a))
(begin (newline)
(print "辺長を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "辺Ｂ")
(let ((hen-b (read)))
(if (not (real? hen-b))
(begin (newline)
(print "辺長を入力してください")
(newline)
(loop-02 (+ count 1)))
(if (not (positive? hen-b))
(begin (newline)
(print "辺長を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop-03 ((count 1))
(print "辺Ｃ")
(let ((hen-c (read)))
(if (not (real? hen-c))
(begin (newline)
(print "辺長を入力してください")
(newline)
(loop-03 (+ count 1)))
(if (not (positive? hen-c))
(begin (newline)
(print "辺長を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(if (not (heron? hen-a hen-b hen-c))
(begin (newline)
(print "三角形になりません")
(newline)
(print "最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 1 cont) (begin (loop1 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline))))))
(begin
(let* (
(kaku-a (/.
(- (+ (expt hen-b 2) (expt hen-c 2)) (expt hen-a 2))
(* 2 hen-b hen-c)
))
(kaku-a1 (* 180/pi (acos kaku-a)))
(kaku-b (/.
(- (+ (expt hen-c 2) (expt hen-a 2)) (expt hen-b 2))
(* 2 hen-c hen-a)
))
(kaku-b1 (* 180/pi (acos kaku-b)))
(kaku-a2 (convert10->60 kaku-a1))
(kaku-b2 (convert10->60 kaku-b1))
(t (heron hen-a hen-b hen-c))
(menseki (addtail2 t))
)
(newline)
(print "角Ａ " kaku-a2)
(print "角Ｂ " kaku-b2)
(newline)
(print "面積 " menseki)
(newline)
(print "最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 1 cont) (begin (loop1 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
)))))))))))))))))))))))
((2) (begin
(let loop1 ((count 1))
(print "二辺夾角既知")
(newline)
(let loop-01 ((count 1))
(print "辺Ａ")
(let ((hen-a (read)))
(if (not (real? hen-a))
(begin (newline)
(print "辺長を入力してください")
(newline)
(loop-01 (+ count 1)))
(if (not (positive? hen-a))
(begin (newline)
(print "辺長を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "辺Ｂ")
(let ((hen-b (read)))
(if (not (real? hen-b))
(begin (newline)
(print "辺長を入力してください")
(newline)
(loop-02 (+ count 1)))
(if (not (positive? hen-b))
(begin (newline)
(print "辺長を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop-03 ((count 1))
(print "角Ｃ 0-00-01 から 179-59-59")
(let ((kaku-c (read)))
(if (not (degrees180? kaku-c))
(begin (newline)
(print "角度を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(if (not (< 0 (convert60->10 kaku-c)))
(begin (newline)
(print "三角形になりません")
(newline)
(print "続ける(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 1 cont) (begin (loop1 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline))))))
(begin
(let* (
(kaku-c1 (convert60->10 kaku-c))
(kaku-a (/.
(* hen-a (sin (* pi/180 kaku-c1)))
(- hen-b (* hen-a (cos (* pi/180 kaku-c1))))
))
(kaku-a1 (* 180/pi (atan kaku-a)))
(kaku-a2 (add180 kaku-a1))
(hen-c (sqrt
(- (+ (expt hen-a 2) (expt hen-b 2))
(* 2 hen-a hen-b (cos (* pi/180 kaku-c1)))
)))
(kaku-a3 (convert10->60 kaku-a2))
(hen-c1 (addtail hen-c))
(t (heron hen-a hen-b hen-c))
(menseki (addtail2 t))
)
(newline)
(print "角Ａ " kaku-a3)
(print "辺Ｃ " hen-c1)
(newline)
(print "面積 " menseki)
(newline)
(print "最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 1 cont) (begin (loop1 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
))))))))))))))))))))))
((3) (begin
(let loop1 ((count 1))
(print "二角夾辺既知")
(newline)
(let loop-01 ((count 1))
(print "辺Ａ")
(let ((hen-a (read)))
(if (not (real? hen-a))
(begin (newline)
(print "辺長を入力してください")
(newline)
(loop-01 (+ count 1)))
(if (not (positive? hen-a))
(begin (newline)
(print "辺長を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "角Ｂ 0-00-01 から 179-59-59")
(let ((kaku-b (read)))
(if (not (degrees180? kaku-b))
(begin (newline)
(print "角度を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop-03 ((count 1))
(print "角Ｃ 0-00-01 から 179-59-59")
(let ((kaku-c (read)))
(if (not (degrees180? kaku-c))
(begin (newline)
(print "角度を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(if (or
(not (< 0 (convert60->10 kaku-b)))
(not (< 0 (convert60->10 kaku-c)))
(not
(< 0 (+ (convert60->10 kaku-b) (convert60->10 kaku-c)) 180)
)
)
(begin (newline)
(print "三角形になりません")
(newline)
(print "続ける(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 1 cont) (begin (loop1 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline))))))
(begin
(let* (
(kaku-b1 (convert60->10 kaku-b))
(kaku-c1 (convert60->10 kaku-c))
(hen-b (/.
(* hen-a (sin (* pi/180 kaku-b1)))
(sin (* pi/180 (+ kaku-b1 kaku-c1)))
))
(hen-c (/.
(* hen-a (sin (* pi/180 kaku-c1)))
(sin (* pi/180 (+ kaku-b1 kaku-c1)))
))
(hen-b1 (addtail hen-b))
(hen-c1 (addtail hen-c))
(t (heron hen-a hen-b hen-c))
(menseki (addtail2 t))
)
(newline)
(print "辺Ｂ " hen-b1)
(print "辺Ｃ " hen-c1)
(newline)
(print "面積 " menseki)
(newline)
(print "最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 1 cont) (begin (loop1 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
)))))))))))))))))))))
)))
(provide "survey-12")
;;-----------------------------------------------------------------------------
;; calc/survey-13.scm
(define-module survey-13
(export zahyou-calc))
(select-module survey-13)
(add-load-path ".")
(use surveymod)
(use math.const)
(define (zahyou-calc)
(newline)
(let loop0 ((count 1))
(print "座標計算")
(newline)
(let loop-01 ((count 1))
(print "Ａ点 Ｘ座標")
(let ((Ax (read)))
(if (not (real? Ax))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "Ａ点 Ｙ座標")
(let ((Ay (read)))
(if (not (real? Ay))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop1 ((count 1))
(let loop-03 ((count 1))
(print "Ａ点からの方向角")
(let ((houkou-kaku (read)))
(if (not (degrees360? houkou-kaku))
(begin (newline)
(print "方向角を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(let loop-04 ((count 1))
(print "Ａ点からの距離")
(let ((kyori (read)))
(if (not (real? kyori))
(begin (newline)
(print "距離を入力してください")
(newline)
(loop-04 (+ count 1)))
(if (negative? kyori)
(begin (newline)
(print "距離を入力してください")
(newline)
(loop-04 (+ count 1)))
(begin
(let* (
(houkou-kaku1 (convert60->10 houkou-kaku))
(zenshi-x1 (* kyori (cos (* houkou-kaku1 pi/180))))
(zenshi-x2 (+ Ax zenshi-x1))
(zenshi-x3 (addtail zenshi-x2))
(zenshi-y1 (* kyori (sin (* houkou-kaku1 pi/180))))
(zenshi-y2 (+ Ay zenshi-y1))
(zenshi-y3 (addtail zenshi-y2))
)
(newline)
(print "Ｂ点 Ｘ座標 " zenshi-x3)
(print "Ｂ点 Ｙ座標 " zenshi-y3)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
)))))))))))))))))))))))
(provide "survey-13")
;;-----------------------------------------------------------------------------
;; calc/survey-14.scm
(define-module survey-14
(export gyaku-calc))
(select-module survey-14)
(add-load-path ".")
(use surveymod)
(use math.const)
(define (gyaku-calc)
(newline)
(let loop0 ((count 1))
(print "逆計算")
(newline)
(let loop-01 ((count 1))
(print "Ａ点 Ｘ座標")
(let ((Ax (read)))
(if (not (real? Ax))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "Ａ点 Ｙ座標")
(let ((Ay (read)))
(if (not (real? Ay))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop1 ((count 1))
(let loop-03 ((count 1))
(print "Ｂ点 Ｘ座標")
(let ((Bx (read)))
(if (not (real? Bx))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(let loop-04 ((count 1))
(print "Ｂ点 Ｙ座標")
(let ((By (read)))
(if (not (real? By))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-04 (+ count 1)))
(begin
(let* (
(kyori1
(sqrt (+ (expt (- By Ay) 2)
(expt (- Bx Ax) 2))))
(kyori2 (addtail kyori1))
(houkou-kaku1 (* (atan (- By Ay) (- Bx Ax)) 180/pi))
(houkou-kaku2 (add360 houkou-kaku1))
(houkou-kaku3 (convert10->60 houkou-kaku2))
)
(newline)
(print "Ａ点からＢ点への方向角 " houkou-kaku3)
(print "Ａ点からＢ点までの距離 " kyori2)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
))))))))))))))))))))))
(provide "survey-14")
;;-----------------------------------------------------------------------------
;; calc/survey-15.scm
(define-module survey-15
(export clothoid-calc))
(select-module survey-15)
(add-load-path ".")
(use surveymod)
(use math.const)
(define (clothoid-calc)
(newline)
(print "クロソイド曲線計算 左カーブ(1) 右カーブ(2)")
(let ((curve (read))) (newline)
(case curve
((1) (begin
(let loop0 ((count 1))
(print "クロソイド曲線計算 左カーブ")
(newline)
(let loop-01 ((count 1))
(print "始点 Ｘ座標")
(let ((Xo (read)))
(if (not (real? Xo))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "始点 Ｙ座標")
(let ((Yo (read)))
(if (not (real? Yo))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop-03 ((count 1))
(print "終点 Ｘ座標")
(let ((Xz (read)))
(if (not (real? Xz))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(let loop-04 ((count 1))
(print "終点 Ｙ座標")
(let ((Yz (read)))
(if (not (real? Yz))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-04 (+ count 1)))
(begin
(let loop-05 ((count 1))
(print "クロソイド曲線長")
(let ((Lz (read)))
(if (not (real? Lz))
(begin (newline)
(print "クロソイド曲線長を入力してください")
(newline)
(loop-05 (+ count 1)))
(if (not (positive? Lz))
(begin (newline)
(print "クロソイド曲線長を入力してください")
(newline)
(loop-05 (+ count 1)))
(begin
(let loop-06 ((count 1))
(print "パラメーター")
(let ((A (read)))
(if (not (real? A))
(begin (newline)
(print "パラメーターを入力してください")
(newline)
(loop-06 (+ count 1)))
(begin
(let loop1 ((count 1))
(let loop-07 ((count 1))
(print "Ｐ点までの曲線長")
(let ((L (read)))
(if (not (real? L))
(begin (newline)
(print "Ｐ点までの曲線長を入力してください")
(newline)
(loop-07 (+ count 1)))
(if (negative? L)
(begin (newline)
(print "Ｐ点までの曲線長を入力してください")
(newline)
(loop-07 (+ count 1)))
(begin
(let* (
(Rz (/. (expt A 2) Lz))
(x1z (* (/. (expt Lz 2) (* 6 Rz))
(- (+ (- 1 (/. (expt Lz 2) (* 56 (expt Rz 2))))
(/. (expt Lz 4) (* 7040 (expt Rz 4))))
(/. (expt Lz 6) (* 1612800 (expt Rz 6)))) ))
(y1z (* Lz
(- (+ (- 1 (/. (expt Lz 2) (* 40 (expt Rz 2))))
(/. (expt Lz 4) (* 3456 (expt Rz 4))))
(/. (expt Lz 6) (* 599040 (expt Rz 6)))) ))
(sigma-z (* (atan (/. x1z y1z)) 180/pi))
(R (/. (expt A 2) L))
(x1 (* (/. (expt L 2) (* 6 R))
(- (+ (- 1 (/. (expt L 2) (* 56 (expt R 2))))
(/. (expt L 4) (* 7040 (expt R 4))))
(/. (expt L 6) (* 1612800 (expt R 6)))) ))
(y1 (* L
(- (+ (- 1 (/. (expt L 2) (* 40 (expt R 2))))
(/. (expt L 4) (* 3456 (expt R 4))))
(/. (expt L 6) (* 599040 (expt R 6)))) ))
(R1 (addtail R))
(tau (* (/. L (* 2 R)) 180/pi))
(sigma (* (atan (/. x1 y1)) 180/pi))
(So (sqrt (+ (expt x1 2) (expt y1 2))))
(So1 (addtail So))
(H-sigma-z (* (atan (- Yz Yo) (- Xz Xo)) 180/pi))
(H-sigma-z2 (add360 H-sigma-z))
(H (+ H-sigma-z2 sigma-z))
(H1 (cut360 H))
(Ho (- H1 sigma))
(Ho1 (add360 Ho))
(Xp (+ Xo (* So (cos (* Ho1 pi/180)))))
(Yp (+ Yo (* So (sin (* Ho1 pi/180)))))
(Hp (- H1 tau))
(Hp1 (add360 Hp))
(Xp1 (addtail Xp))
(Yp1 (addtail Yp))
(H1-kakudo (convert10->60 H1))
(Ho1-kakudo (convert10->60 Ho1))
(Hp1-kakudo (convert10->60 Hp1))
(s-kakudo (convert10->60 tau))
(k-kakudo (convert10->60 sigma))
(Xm (+ x1 (* R (cos (* pi/180 tau)))))
(Ym (- y1 (* R (sin (* pi/180 tau)))))
(Tk (* x1 (/. 1 (sin (* pi/180 tau)))))
(Tl (- y1 (* x1 (/. 1 (tan (* pi/180 tau))))))
(Xm1 (addtail Xm))
(Ym1 (addtail Ym))
(Tk1 (addtail Tk))
(Tl1 (addtail Tl))
)
(newline)
(print "半径 " R1)
(print "動径 " So1)
(newline)
(print "方向角(H) " H1-kakudo)
(print "方向角(Ho) " Ho1-kakudo)
(print "方向角(Hp) " Hp1-kakudo)
(newline)
(print "Ｐ点Ｘ座標 " Xp1)
(print "Ｐ点Ｙ座標 " Yp1)
(newline)
(print "接線角 " s-kakudo)
(print "極角 " k-kakudo)
(newline)
(print "始点を原点とする座標系おける")
(print "曲率中心(M)")
(print "Ｘ座標 " Xm1)
(print "Ｙ座標 " Ym1)
(newline)
(print "短接線長 " Tk1)
(print "長接線長 " Tl1)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
)))))))))))))))))))))))))))))))))))))
((2) (begin
(let loop0 ((count 1))
(print "クロソイド曲線計算 右カーブ")
(newline)
(let loop-01 ((count 1))
(print "始点 Ｘ座標")
(let ((Xo (read)))
(if (not (real? Xo))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "始点 Ｙ座標")
(let ((Yo (read)))
(if (not (real? Yo))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop-03 ((count 1))
(print "終点 Ｘ座標")
(let ((Xz (read)))
(if (not (real? Xz))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(let loop-04 ((count 1))
(print "終点 Ｙ座標")
(let ((Yz (read)))
(if (not (real? Yz))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-04 (+ count 1)))
(begin
(let loop-05 ((count 1))
(print "クロソイド曲線長")
(let ((Lz (read)))
(if (not (real? Lz))
(begin (newline)
(print "クロソイド曲線長を入力してください")
(newline)
(loop-05 (+ count 1)))
(if (not (positive? Lz))
(begin (newline)
(print "クロソイド曲線長を入力してください")
(newline)
(loop-05 (+ count 1)))
(begin
(let loop-06 ((count 1))
(print "パラメーター")
(let ((A (read)))
(if (not (real? A))
(begin (newline)
(print "パラメーターを入力してください")
(newline)
(loop-06 (+ count 1)))
(begin
(let loop1 ((count 1))
(let loop-07 ((count 1))
(print "Ｐ点までの曲線長")
(let ((L (read)))
(if (not (real? L))
(begin (newline)
(print "Ｐ点までの曲線長を入力してください")
(newline)
(loop-07 (+ count 1)))
(if (negative? L)
(begin (newline)
(print "Ｐ点までの曲線長を入力してください")
(newline)
(loop-07 (+ count 1)))
(begin
(let* (
(Rz (/. (expt A 2) Lz))
(x1z (* (/. (expt Lz 2) (* 6 Rz))
(- (+ (- 1 (/. (expt Lz 2) (* 56 (expt Rz 2))))
(/. (expt Lz 4) (* 7040 (expt Rz 4))))
(/. (expt Lz 6) (* 1612800 (expt Rz 6)))) ))
(y1z (* Lz
(- (+ (- 1 (/. (expt Lz 2) (* 40 (expt Rz 2))))
(/. (expt Lz 4) (* 3456 (expt Rz 4))))
(/. (expt Lz 6) (* 599040 (expt Rz 6)))) ))
(sigma-z (* (atan (/. x1z y1z)) 180/pi))
(R (/. (expt A 2) L))
(x1 (* (/. (expt L 2) (* 6 R))
(- (+ (- 1 (/. (expt L 2) (* 56 (expt R 2))))
(/. (expt L 4) (* 7040 (expt R 4))))
(/. (expt L 6) (* 1612800 (expt R 6)))) ))
(y1 (* L
(- (+ (- 1 (/. (expt L 2) (* 40 (expt R 2))))
(/. (expt L 4) (* 3456 (expt R 4))))
(/. (expt L 6) (* 599040 (expt R 6)))) ))
(R1 (addtail R))
(tau (* (/. L (* 2 R)) 180/pi))
(sigma (* (atan (/. x1 y1)) 180/pi))
(So (sqrt (+ (expt x1 2) (expt y1 2))))
(So1 (addtail So))
(H-sigma-z (* (atan (- Yz Yo) (- Xz Xo)) 180/pi))
(H-sigma-z2 (add360 H-sigma-z))
(H (- H-sigma-z2 sigma-z))
(H1 (add360 H))
(Ho (+ H1 sigma))
(Ho1 (cut360 Ho))
(Xp (+ Xo (* So (cos (* Ho1 pi/180)))))
(Yp (+ Yo (* So (sin (* Ho1 pi/180)))))
(Hp (+ H1 tau))
(Hp1 (cut360 Hp))
(Xp1 (addtail Xp))
(Yp1 (addtail Yp))
(H1-kakudo (convert10->60 H1))
(Ho1-kakudo (convert10->60 Ho1))
(Hp1-kakudo (convert10->60 Hp1))
(s-kakudo (convert10->60 tau))
(k-kakudo (convert10->60 sigma))
(Xm (+ x1 (* R (cos (* pi/180 tau)))))
(Ym (- y1 (* R (sin (* pi/180 tau)))))
(Tk (* x1 (/. 1 (sin (* pi/180 tau)))))
(Tl (- y1 (* x1 (/. 1 (tan (* pi/180 tau))))))
(Xm1 (addtail Xm))
(Ym1 (addtail Ym))
(Tk1 (addtail Tk))
(Tl1 (addtail Tl))
)
(newline)
(print "半径 " R1)
(print "動径 " So1)
(newline)
(print "方向角(H) " H1-kakudo)
(print "方向角(Ho) " Ho1-kakudo)
(print "方向角(Hp) " Hp1-kakudo)
(newline)
(print "Ｐ点Ｘ座標 " Xp1)
(print "Ｐ点Ｙ座標 " Yp1)
(newline)
(print "接線角 " s-kakudo)
(print "極角 " k-kakudo)
(newline)
(print "始点を原点とする座標系おける")
(print "曲率中心(M)")
(print "Ｘ座標 " Xm1)
(print "Ｙ座標 " Ym1)
(newline)
(print "短接線長 " Tk1)
(print "長接線長 " Tl1)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
)))))))))))))))))))))))))))))))))))))
)))
(provide "survey-15")
;;-----------------------------------------------------------------------------
;; calc/survey-16.scm
(define-module survey-16
(export takasa-hirei-calc))
(select-module survey-16)
(add-load-path ".")
(use surveymod)
;(use math.const)
(define (takasa-hirei-calc)
(newline)
(print "高さ(比例)計算")
(newline)
(let loop0 ((count 1))
(let loop-01 ((count 1))
(print "基準となる点の標高")
(let ((kijyunhyoukou (read)))
(if (not (real? kijyunhyoukou))
(begin (newline)
(print "標高を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "勾配 何％")
(let ((koubai (read)))
(if (not (real? koubai))
(begin (newline)
(print "勾配を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop1 ((count 1))
(let loop-03 ((count 1))
(print "水平距離")
(let ((suiheikyori (read)))
(if (not (real? suiheikyori))
(begin (newline)
(print "水平距離を入力してください")
(newline)
(loop-03 (+ count 1)))
(if (negative? suiheikyori)
(begin (newline)
(print "水平距離を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(let* (
(hyoukousa1 (* suiheikyori (/. koubai 100)))
(hyoukou1 (+ kijyunhyoukou hyoukousa1))
(hyoukou2 (addtail hyoukou1))
)
(newline)
(print "標高 " hyoukou2)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
)))))))))))))))))))
(provide "survey-16")
;;-----------------------------------------------------------------------------
;; calc/survey-17.scm
(define-module survey-17
(export shuukei-calc))
(select-module survey-17)
;(add-load-path ".")
;(use surveymod)
;(use math.const)
(define (shuukei-calc)
(newline)
(print "集計計算")
(newline)
(print "第１入力")
(let ((s-01 (read)))
(if (string=? "end" (x->string s-01))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-01 (+ 0 s-01)))
(print "合計: " g-01)
(print "第２入力")
(let ((s-02 (read)))
(if (string=? "end" (x->string s-02))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-02 (+ g-01 s-02)))
(print "合計: " g-02)
(print "第３入力")
(let ((s-03 (read)))
(if (string=? "end" (x->string s-03))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-03 (+ g-02 s-03)))
(print "合計: " g-03)
(print "第４入力")
(let ((s-04 (read)))
(if (string=? "end" (x->string s-04))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-04 (+ g-03 s-04)))
(print "合計: " g-04)
(print "第５入力")
(let ((s-05 (read)))
(if (string=? "end" (x->string s-05))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-05 (+ g-04 s-05)))
(print "合計: " g-05)
(print "第６入力")
(let ((s-06 (read)))
(if (string=? "end" (x->string s-06))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-06 (+ g-05 s-06)))
(print "合計: " g-06)
(print "第７入力")
(let ((s-07 (read)))
(if (string=? "end" (x->string s-07))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-07 (+ g-06 s-07)))
(print "合計: " g-07)
(print "第８入力")
(let ((s-08 (read)))
(if (string=? "end" (x->string s-08))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-08 (+ g-07 s-08)))
(print "合計: " g-08)
(print "第９入力")
(let ((s-09 (read)))
(if (string=? "end" (x->string s-09))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-09 (+ g-08 s-09)))
(print "合計: " g-09)
(print "第10入力")
(let ((s-10 (read)))
(if (string=? "end" (x->string s-10))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-10 (+ g-09 s-10)))
(print "合計: " g-10)
(print "第11入力")
(let ((s-11 (read)))
(if (string=? "end" (x->string s-11))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-11 (+ g-10 s-11)))
(print "合計: " g-11)
(print "第12入力")
(let ((s-12 (read)))
(if (string=? "end" (x->string s-12))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-12 (+ g-11 s-12)))
(print "合計: " g-12)
(print "第13入力")
(let ((s-13 (read)))
(if (string=? "end" (x->string s-13))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-13 (+ g-12 s-13)))
(print "合計: " g-13)
(print "第14入力")
(let ((s-14 (read)))
(if (string=? "end" (x->string s-14))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-14 (+ g-13 s-14)))
(print "合計: " g-14)
(print "第15入力")
(let ((s-15 (read)))
(if (string=? "end" (x->string s-15))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-15 (+ g-14 s-15)))
(print "合計: " g-15)
(print "第16入力")
(let ((s-16 (read)))
(if (string=? "end" (x->string s-16))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-16 (+ g-15 s-16)))
(print "合計: " g-16)
(print "第17入力")
(let ((s-17 (read)))
(if (string=? "end" (x->string s-17))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-17 (+ g-16 s-17)))
(print "合計: " g-17)
(print "第18入力")
(let ((s-18 (read)))
(if (string=? "end" (x->string s-18))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-18 (+ g-17 s-18)))
(print "合計: " g-18)
(print "第19入力")
(let ((s-19 (read)))
(if (string=? "end" (x->string s-19))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-19 (+ g-18 s-19)))
(print "合計: " g-19)
(print "第20入力")
(let ((s-20 (read)))
(if (string=? "end" (x->string s-20))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-20 (+ g-19 s-20)))
(print "合計: " g-20)
(print "第21入力")
(let ((s-21 (read)))
(if (string=? "end" (x->string s-21))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-21 (+ g-20 s-21)))
(print "合計: " g-21)
(print "第22入力")
(let ((s-22 (read)))
(if (string=? "end" (x->string s-22))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-22 (+ g-21 s-22)))
(print "合計: " g-22)
(print "第23入力")
(let ((s-23 (read)))
(if (string=? "end" (x->string s-23))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-23 (+ g-22 s-23)))
(print "合計: " g-23)
(print "第24入力")
(let ((s-24 (read)))
(if (string=? "end" (x->string s-24))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-24 (+ g-23 s-24)))
(print "合計: " g-24)
(print "第25入力")
(let ((s-25 (read)))
(if (string=? "end" (x->string s-25))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-25 (+ g-24 s-25)))
(print "合計: " g-25)
(print "第26入力")
(let ((s-26 (read)))
(if (string=? "end" (x->string s-26))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-26 (+ g-25 s-26)))
(print "合計: " g-26)
(print "第27入力")
(let ((s-27 (read)))
(if (string=? "end" (x->string s-27))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-27 (+ g-26 s-27)))
(print "合計: " g-27)
(print "第28入力")
(let ((s-28 (read)))
(if (string=? "end" (x->string s-28))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-28 (+ g-27 s-28)))
(print "合計: " g-28)
(print "第29入力")
(let ((s-29 (read)))
(if (string=? "end" (x->string s-29))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-29 (+ g-28 s-29)))
(print "合計: " g-29)
(print "第30入力")
(let ((s-30 (read)))
(if (string=? "end" (x->string s-30))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-30 (+ g-29 s-30)))
(print "合計: " g-30)
(print "第31入力")
(let ((s-31 (read)))
(if (string=? "end" (x->string s-31))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-31 (+ g-30 s-31)))
(print "合計: " g-31)
(print "第32入力")
(let ((s-32 (read)))
(if (string=? "end" (x->string s-32))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-32 (+ g-31 s-32)))
(print "合計: " g-32)
(print "第33入力")
(let ((s-33 (read)))
(if (string=? "end" (x->string s-33))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-33 (+ g-32 s-33)))
(print "合計: " g-33)
(print "第34入力")
(let ((s-34 (read)))
(if (string=? "end" (x->string s-34))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-34 (+ g-33 s-34)))
(print "合計: " g-34)
(print "第35入力")
(let ((s-35 (read)))
(if (string=? "end" (x->string s-35))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-35 (+ g-34 s-35)))
(print "合計: " g-35)
(print "第36入力")
(let ((s-36 (read)))
(if (string=? "end" (x->string s-36))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-36 (+ g-35 s-36)))
(print "合計: " g-36)
(print "第37入力")
(let ((s-37 (read)))
(if (string=? "end" (x->string s-37))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-37 (+ g-36 s-37)))
(print "合計: " g-37)
(print "第38入力")
(let ((s-38 (read)))
(if (string=? "end" (x->string s-38))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-38 (+ g-37 s-38)))
(print "合計: " g-38)
(print "第39入力")
(let ((s-39 (read)))
(if (string=? "end" (x->string s-39))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-39 (+ g-38 s-39)))
(print "合計: " g-39)
(print "第40入力")
(let ((s-40 (read)))
(if (string=? "end" (x->string s-40))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-40 (+ g-39 s-40)))
(print "合計: " g-40)
(print "第41入力")
(let ((s-41 (read)))
(if (string=? "end" (x->string s-41))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-41 (+ g-40 s-41)))
(print "合計: " g-41)
(print "第42入力")
(let ((s-42 (read)))
(if (string=? "end" (x->string s-42))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-42 (+ g-41 s-42)))
(print "合計: " g-42)
(print "第43入力")
(let ((s-43 (read)))
(if (string=? "end" (x->string s-43))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-43 (+ g-42 s-43)))
(print "合計: " g-43)
(print "第44入力")
(let ((s-44 (read)))
(if (string=? "end" (x->string s-44))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-44 (+ g-43 s-44)))
(print "合計: " g-44)
(print "第45入力")
(let ((s-45 (read)))
(if (string=? "end" (x->string s-45))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-45 (+ g-44 s-45)))
(print "合計: " g-45)
(print "第46入力")
(let ((s-46 (read)))
(if (string=? "end" (x->string s-46))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-46 (+ g-45 s-46)))
(print "合計: " g-46)
(print "第47入力")
(let ((s-47 (read)))
(if (string=? "end" (x->string s-47))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-47 (+ g-46 s-47)))
(print "合計: " g-47)
(print "第48入力")
(let ((s-48 (read)))
(if (string=? "end" (x->string s-48))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-48 (+ g-47 s-48)))
(print "合計: " g-48)
(print "第49入力")
(let ((s-49 (read)))
(if (string=? "end" (x->string s-49))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-49 (+ g-48 s-49)))
(print "合計: " g-49)
(print "第50入力")
(let ((s-50 (read)))
(if (string=? "end" (x->string s-50))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-50 (+ g-49 s-50)))
(print "合計: " g-50)
(print "第51入力")
(let ((s-51 (read)))
(if (string=? "end" (x->string s-51))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-51 (+ g-50 s-51)))
(print "合計: " g-51)
(print "第52入力")
(let ((s-52 (read)))
(if (string=? "end" (x->string s-52))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-52 (+ g-51 s-52)))
(print "合計: " g-52)
(print "第53入力")
(let ((s-53 (read)))
(if (string=? "end" (x->string s-53))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-53 (+ g-52 s-53)))
(print "合計: " g-53)
(print "第54入力")
(let ((s-54 (read)))
(if (string=? "end" (x->string s-54))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-54 (+ g-53 s-54)))
(print "合計: " g-54)
(print "第55入力")
(let ((s-55 (read)))
(if (string=? "end" (x->string s-55))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-55 (+ g-54 s-55)))
(print "合計: " g-55)
(print "第56入力")
(let ((s-56 (read)))
(if (string=? "end" (x->string s-56))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-56 (+ g-55 s-56)))
(print "合計: " g-56)
(print "第57入力")
(let ((s-57 (read)))
(if (string=? "end" (x->string s-57))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-57 (+ g-56 s-57)))
(print "合計: " g-57)
(print "第58入力")
(let ((s-58 (read)))
(if (string=? "end" (x->string s-58))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-58 (+ g-57 s-58)))
(print "合計: " g-58)
(print "第59入力")
(let ((s-59 (read)))
(if (string=? "end" (x->string s-59))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-59 (+ g-58 s-59)))
(print "合計: " g-59)
(print "第60入力")
(let ((s-60 (read)))
(if (string=? "end" (x->string s-60))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-60 (+ g-59 s-60)))
(print "合計: " g-60)
(print "第61入力")
(let ((s-61 (read)))
(if (string=? "end" (x->string s-61))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-61 (+ g-60 s-61)))
(print "合計: " g-61)
(print "第62入力")
(let ((s-62 (read)))
(if (string=? "end" (x->string s-62))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-62 (+ g-61 s-62)))
(print "合計: " g-62)
(print "第63入力")
(let ((s-63 (read)))
(if (string=? "end" (x->string s-63))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-63 (+ g-62 s-63)))
(print "合計: " g-63)
(print "第64入力")
(let ((s-64 (read)))
(if (string=? "end" (x->string s-64))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-64 (+ g-63 s-64)))
(print "合計: " g-64)
(print "第65入力")
(let ((s-65 (read)))
(if (string=? "end" (x->string s-65))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-65 (+ g-64 s-65)))
(print "合計: " g-65)
(print "第66入力")
(let ((s-66 (read)))
(if (string=? "end" (x->string s-66))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-66 (+ g-65 s-66)))
(print "合計: " g-66)
(print "第67入力")
(let ((s-67 (read)))
(if (string=? "end" (x->string s-67))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-67 (+ g-66 s-67)))
(print "合計: " g-67)
(print "第68入力")
(let ((s-68 (read)))
(if (string=? "end" (x->string s-68))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-68 (+ g-67 s-68)))
(print "合計: " g-68)
(print "第69入力")
(let ((s-69 (read)))
(if (string=? "end" (x->string s-69))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-69 (+ g-68 s-69)))
(print "合計: " g-69)
(print "第70入力")
(let ((s-70 (read)))
(if (string=? "end" (x->string s-70))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-70 (+ g-69 s-70)))
(print "合計: " g-70)
(print "第71入力")
(let ((s-71 (read)))
(if (string=? "end" (x->string s-71))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-71 (+ g-70 s-71)))
(print "合計: " g-71)
(print "第72入力")
(let ((s-72 (read)))
(if (string=? "end" (x->string s-72))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-72 (+ g-71 s-72)))
(print "合計: " g-72)
(print "第73入力")
(let ((s-73 (read)))
(if (string=? "end" (x->string s-73))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-73 (+ g-72 s-73)))
(print "合計: " g-73)
(print "第74入力")
(let ((s-74 (read)))
(if (string=? "end" (x->string s-74))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-74 (+ g-73 s-74)))
(print "合計: " g-74)
(print "第75入力")
(let ((s-75 (read)))
(if (string=? "end" (x->string s-75))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-75 (+ g-74 s-75)))
(print "合計: " g-75)
(print "第76入力")
(let ((s-76 (read)))
(if (string=? "end" (x->string s-76))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-76 (+ g-75 s-76)))
(print "合計: " g-76)
(print "第77入力")
(let ((s-77 (read)))
(if (string=? "end" (x->string s-77))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-77 (+ g-76 s-77)))
(print "合計: " g-77)
(print "第78入力")
(let ((s-78 (read)))
(if (string=? "end" (x->string s-78))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-78 (+ g-77 s-78)))
(print "合計: " g-78)
(print "第79入力")
(let ((s-79 (read)))
(if (string=? "end" (x->string s-79))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-79 (+ g-78 s-79)))
(print "合計: " g-79)
(print "第80入力")
(let ((s-80 (read)))
(if (string=? "end" (x->string s-80))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-80 (+ g-79 s-80)))
(print "合計: " g-80)
(print "第81入力")
(let ((s-81 (read)))
(if (string=? "end" (x->string s-81))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-81 (+ g-80 s-81)))
(print "合計: " g-81)
(print "第82入力")
(let ((s-82 (read)))
(if (string=? "end" (x->string s-82))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-82 (+ g-81 s-82)))
(print "合計: " g-82)
(print "第83入力")
(let ((s-83 (read)))
(if (string=? "end" (x->string s-83))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-83 (+ g-82 s-83)))
(print "合計: " g-83)
(print "第84入力")
(let ((s-84 (read)))
(if (string=? "end" (x->string s-84))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-84 (+ g-83 s-84)))
(print "合計: " g-84)
(print "第85入力")
(let ((s-85 (read)))
(if (string=? "end" (x->string s-85))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-85 (+ g-84 s-85)))
(print "合計: " g-85)
(print "第86入力")
(let ((s-86 (read)))
(if (string=? "end" (x->string s-86))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-86 (+ g-85 s-86)))
(print "合計: " g-86)
(print "第87入力")
(let ((s-87 (read)))
(if (string=? "end" (x->string s-87))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-87 (+ g-86 s-87)))
(print "合計: " g-87)
(print "第88入力")
(let ((s-88 (read)))
(if (string=? "end" (x->string s-88))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-88 (+ g-87 s-88)))
(print "合計: " g-88)
(print "第89入力")
(let ((s-89 (read)))
(if (string=? "end" (x->string s-89))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-89 (+ g-88 s-89)))
(print "合計: " g-89)
(print "第90入力")
(let ((s-90 (read)))
(if (string=? "end" (x->string s-90))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-90 (+ g-89 s-90)))
(print "合計: " g-90)
(print "第91入力")
(let ((s-91 (read)))
(if (string=? "end" (x->string s-91))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-91 (+ g-90 s-91)))
(print "合計: " g-91)
(print "第92入力")
(let ((s-92 (read)))
(if (string=? "end" (x->string s-92))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-92 (+ g-91 s-92)))
(print "合計: " g-92)
(print "第93入力")
(let ((s-93 (read)))
(if (string=? "end" (x->string s-93))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-93 (+ g-92 s-93)))
(print "合計: " g-93)
(print "第94入力")
(let ((s-94 (read)))
(if (string=? "end" (x->string s-94))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-94 (+ g-93 s-94)))
(print "合計: " g-94)
(print "第95入力")
(let ((s-95 (read)))
(if (string=? "end" (x->string s-95))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-95 (+ g-94 s-95)))
(print "合計: " g-95)
(print "第96入力")
(let ((s-96 (read)))
(if (string=? "end" (x->string s-96))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-96 (+ g-95 s-96)))
(print "合計: " g-96)
(print "第97入力")
(let ((s-97 (read)))
(if (string=? "end" (x->string s-97))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-97 (+ g-96 s-97)))
(print "合計: " g-97)
(print "第98入力")
(let ((s-98 (read)))
(if (string=? "end" (x->string s-98))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-98 (+ g-97 s-98)))
(print "合計: " g-98)
(print "第99入力")
(let ((s-99 (read)))
(if (string=? "end" (x->string s-99))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-99 (+ g-98 s-99)))
(print "合計: " g-99)
(print "第100入力")
(let ((s-100 (read)))
(if (string=? "end" (x->string s-100))
(begin (newline)
(print "計算終了")
(newline))
(begin
(let ((g-100 (+ g-99 s-100)))
(print "合計: " g-100)
))))))))))))))))))))))))))))))))))))))))
))))))))))))))))))))))))))))))))))))))))
))))))))))))))))))))))))))))))))))))))))
))))))))))))))))))))))))))))))))))))))))
))))))))))))))))))))))))))))))))))))))))
))))))))))))))))))))))))))))))))))))))))
))))))))))))))))))))))))))))))))))))))))
))))))))))))))))))))))))))))))))))))))))
))))))))))))))))))))))))))))))))))))))))
)))))))))))))))))))))))))))))))))))))))))
(provide "survey-17")
;;-----------------------------------------------------------------------------
;; calc/survey-18.scm
(define-module survey-18
(export suijyun-calc))
(select-module survey-18)
(add-load-path ".")
(use surveymod)
;(use math.const)
(define (suijyun-calc)
(newline)
(let loop0 ((count 1))
(print "水準計算")
(newline)
(let loop-01 ((count 1))
(print "後視地盤高")
(let ((koushi-jiban (read)))
(if (not (real? koushi-jiban))
(begin (newline)
(print "後視地盤高を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "後視高")
(let ((koushi (read)))
(if (not (real? koushi))
(begin (newline)
(print "後視高を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let ((kikai (addtail (+ koushi-jiban koushi))))
(print "器械高")
(print kikai)
(let loop1 ((count 1))
(newline)
(let loop-03 ((count 1))
(print "前視高")
(let ((zenshi (read)))
(if (not (real? zenshi))
(begin (newline)
(print "前視高を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(let ((zenshi-jiban (addtail (- (x->number kikai) zenshi))))
(newline)
(print "前視地盤高 " zenshi-jiban)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
)))))))))))))))))))
(provide "survey-18")
;;-----------------------------------------------------------------------------
;; calc/survey-19.scm
(define-module survey-19
(export suisen-en-calc))
(select-module survey-19)
(add-load-path ".")
(use surveymod)
(use math.const)
(define (suisen-en-calc)
(newline)
(let loop0 ((count 1))
(print "垂線計算(円)")
(newline)
(let loop-01 ((count 1))
(print "円Ａの中心 Ｘ座標")
(let ((Ax (read)))
(if (not (real? Ax))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "円Ａの中心 Ｙ座標")
(let ((Ay (read)))
(if (not (real? Ay))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop-03 ((count 1))
(print "円Ａの半径")
(let ((Ra (read)))
(if (not (real? Ra))
(begin (newline)
(print "半径を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(if (not (positive? Ra))
(begin (newline)
(print "半径を入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(let loop1 ((count 1))
(let loop-04 ((count 1))
(print "Ｂ点 Ｘ座標")
(let ((Bx (read)))
(if (not (real? Bx))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-04 (+ count 1)))
(begin
(let loop-05 ((count 1))
(print "Ｂ点 Ｙ座標")
(let ((By (read)))
(if (not (real? By))
(begin (newline)
(print "座標を入力してください")
(newline)
(loop-05 (+ count 1)))
(begin
(if (and (= Ax Bx) (= Ay By))
(begin (newline)
(print "垂線がありません")
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline))))))
(begin
(let* (
(houkou-kaku1 (* (atan (- By Ay) (- Bx Ax)) 180/pi))
(houkou-kaku2 (add360 houkou-kaku1))
(houkou-kaku3 (+ houkou-kaku2 180))
(houkou-kaku4 (cut360 houkou-kaku3))
(Px1 (* Ra (cos (* houkou-kaku2 pi/180))))
(Px2 (+ Ax Px1))
(Px3 (addtail Px2))
(Py1 (* Ra (sin (* houkou-kaku2 pi/180))))
(Py2 (+ Ay Py1))
(Py3 (addtail Py2))
(Lp1 (sqrt (+ (expt (- Bx Px2) 2) (expt (- By Py2) 2))))
(Lp2 (addtail Lp1))
(Qx1 (* Ra (cos (* houkou-kaku4 pi/180))))
(Qx2 (+ Ax Qx1))
(Qx3 (addtail Qx2))
(Qy1 (* Ra (sin (* houkou-kaku4 pi/180))))
(Qy2 (+ Ay Qy1))
(Qy3 (addtail Qy2))
(Lq1 (sqrt (+ (expt (- Bx Qx2) 2) (expt (- By Qy2) 2))))
(Lq2 (addtail Lq1))
)
(newline)
(print "Ｐ点 Ｘ座標 " Px3)
(print "Ｐ点 Ｙ座標 " Py3)
(print "垂線長 " Lp2)
(newline)
(print "Ｑ点 Ｘ座標 " Qx3)
(print "Ｑ点 Ｙ座標 " Qy3)
(print "垂線長 " Lq2)
(newline)
(print "続ける(0) 最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 0 cont) (begin (loop1 (+ count 1))))
((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
))))))))))))))))))))))))))))))
(provide "survey-19")
;;-----------------------------------------------------------------------------
;; calc/survey-20.scm
(define-module survey-20
(export daen-calc))
(select-module survey-20)
(add-load-path ".")
(use surveymod)
(use math.const)
(define (daen-calc)
(newline)
(let loop0 ((count 1))
(print "楕円計算")
(newline)
(let loop-01 ((count 1))
(print "楕円の長半径")
(let ((Lr (read)))
(if (not (real? Lr))
(begin (newline)
(print "長半径を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(if (not (positive? Lr))
(begin (newline)
(print "長半径を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "楕円の短半径")
(let ((Sr (read)))
(if (not (real? Sr))
(begin (newline)
(print "短半径を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(if (not (positive? Sr))
(begin (newline)
(print "短半径を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(if (not (<= Sr Lr))
(begin (newline)
(print "短半径を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let* (
(shuuchou1
(*
(* pi (+ Lr Sr))
(+ 1
(/.
(* 3 (expt (/. (- Lr Sr) (+ Lr Sr)) 2))
(+ 10 (sqrt (- 4 (* 3 (expt (/. (- Lr Sr) (+ Lr Sr)) 2)))))
)
)
)
)
(shuuchou2 (addtail shuuchou1))
(menseki1 (* pi Lr Sr))
(menseki2 (addtail2 menseki1))
(rishin-ritsu1 (sqrt (- 1 (/. (expt Sr 2) (expt Lr 2)))))
(rishin-ritsu2 (addtail rishin-ritsu1))
(henpei-ritsu1 (- 1 (/. Sr Lr)))
(henpei-ritsu2 (addtail henpei-ritsu1))
(daen-ritsu1 (/. Sr Lr))
(daen-ritsu2 (addtail daen-ritsu1))
)
(newline)
(print "楕円周長 " shuuchou2)
(print "楕円面積 " menseki2)
(newline)
(print "離心率 " rishin-ritsu2)
(print "扁平率 " henpei-ritsu2)
(print "楕円率 " daen-ritsu2)
(newline)
(print "最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
)))))))))))))))))))
(provide "survey-20")
;;-----------------------------------------------------------------------------
;; calc/survey-21.scm
(define-module survey-21
(export daikei-calc))
(select-module survey-21)
(add-load-path ".")
(use surveymod)
;(use math.const)
(define (daikei-calc)
(newline)
(let loop0 ((count 1))
(print "台形計算")
(newline)
(let loop-01 ((count 1))
(print "台形の長辺")
(let ((Ll (read)))
(if (not (real? Ll))
(begin (newline)
(print "長辺を入力してください")
(newline)
(loop-01 (+ count 1)))
(begin
(if (not (positive? Ll))
(begin (newline)
(print "長辺を入力してください")
(loop-01 (+ count 1)))
(begin
(let loop-02 ((count 1))
(print "台形の短辺")
(let ((Sl (read)))
(if (not (real? Sl))
(begin (newline)
(print "短辺を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(if (not (positive? Sl))
(begin (newline)
(print "短辺を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(if (not (<= Sl Ll))
(begin (newline)
(print "短辺を入力してください")
(newline)
(loop-02 (+ count 1)))
(begin
(let loop-03 ((count 1))
(print "台形の高さ")
(let ((Hl (read)))
(if (not (real? Hl))
(begin (newline)
(print "高さを入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(if (not (positive? Hl))
(begin (newline)
(print "高さを入力してください")
(newline)
(loop-03 (+ count 1)))
(begin
(let* (
(l1 (+ Sl Ll))
(menseki1 (/. (* l1 Hl) 2))
(menseki2 (addtail2 menseki1))
)
(newline)
(print "台形面積 " menseki2)
(newline)
(print "最初から(1) 終了する(2)")
(let ((cont (read))) (newline)
(cond ((= 1 cont) (begin (loop0 (+ count 1))))
((= 2 cont) (begin (newline) (print "計算終了") (newline)))
)))))))))))))))))))))))))
(provide "survey-21")
;;-----------------------------------------------------------------------------
;; surveyscm.scm
#!/usr/bin/env gosh
;; -*- coding: utf-8 -*-
(add-load-path "./calc")
(use survey-00)
(use survey-01)
(use survey-02)
(use survey-03)
(use survey-04)
(use survey-05)
(use survey-06)
(use survey-07)
(use survey-08)
(use survey-09)
(use survey-10)
(use survey-11)
(use survey-12)
(use survey-13)
(use survey-14)
(use survey-15)
(use survey-16)
(use survey-17)
(use survey-18)
(use survey-19)
(use survey-20)
(use survey-21)
(define (surveyscm)
(let loop2 ((count 1))
(newline)
(print "測量計算Schemeスクリプト surveyscm.scm")
(newline)
(print "(0) トラバース計算 (1) 逆トラバース計算")
(print "(2) 幅杭計算(直線) (3) 幅杭計算(曲線) ")
(print "(4) 垂線計算 (5) 交点計算 ")
(print "(6) 交点計算(円直線) (7) 交点計算(円円) ")
(print "(8) 縦断曲線計算 (9) ヘロン面積計算 ")
(print "(10) 座標面積計算 (11) 単曲線計算 ")
(print "(12) 三角形の解法 (13) 座標計算 ")
(print "(14) 逆計算 (15) クロソイド曲線計算")
(print "(16) 高さ(比例)計算 (17) 集計計算 ")
(print "(18) 水準計算 (19) 垂線計算(円) ")
(print "(20) 楕円計算 (21) 台形計算 ")
(newline)
(print "(99) 終了する")
(newline)
(print "どの計算方法ですか？")
(let ((keisan-houhou (read)))
(case keisan-houhou
((0) (traverse-calc)
(loop2 (+ count 1)))
((1) (inverse-calc)
(loop2 (+ count 1)))
((2) (habagui-chokusen-calc)
(loop2 (+ count 1)))
((3) (habagui-kyokusen-calc)
(loop2 (+ count 1)))
((4) (suisen-calc)
(loop2 (+ count 1)))
((5) (kouten-calc)
(loop2 (+ count 1)))
((6) (kouten-en-chokusen-calc)
(loop2 (+ count 1)))
((7) (kouten-en-en-calc)
(loop2 (+ count 1)))
((8) (jyuudankyokusen-calc)
(loop2 (+ count 1)))
((9) (heron-calc)
(loop2 (+ count 1)))
((10) (menseki-calc)
(loop2 (+ count 1)))
((11) (tankyokusen-calc)
(loop2 (+ count 1)))
((12) (sankakukei-calc)
(loop2 (+ count 1)))
((13) (zahyou-calc)
(loop2 (+ count 1)))
((14) (gyaku-calc)
(loop2 (+ count 1)))
((15) (clothoid-calc)
(loop2 (+ count 1)))
((16) (takasa-hirei-calc)
(loop2 (+ count 1)))
((17) (shuukei-calc)
(loop2 (+ count 1)))
((18) (suijyun-calc)
(loop2 (+ count 1)))
((19) (suisen-en-calc)
(loop2 (+ count 1)))
((20) (daen-calc)
(loop2 (+ count 1)))
((21) (daikei-calc)
(loop2 (+ count 1)))
((99) (newline) (print "終了") (newline))
))))
(define (main args)
(surveyscm)
0)
;;-----------------------------------------------------------------------------