home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1993 #2 / Image.iso / cad / autolo21.zip / AUTOLOG.LSP < prev    next >
Lisp/Scheme  |  1993-06-30  |  44KB  |  1,004 lines
  1. ;Copyright (c) 1993 Andy Harrover
  2. ;Version 1 - 29 July 1991
  3. ;Version 1.1 - 1 September 1991 Support for all hatches
  4. ;Version 1.2 - 12 September 1991 bug fix
  5. ;Version 1.3 - 12 OCT 1991 bug fix
  6. ;Version 1.4 - 24 OCT 1991 bug fix and computation of depths
  7. ;Version 2.0 - 11 MAR 92 MAJOR overhaul of code - split well and geology
  8. ;Version 2.1 - 21 JUN 93 First stable code....long delayed due to work...
  9. ;   !!!!!!! THIS IS VERSION 2.1 !!!!!!!
  10. ;
  11. ;
  12. ;
  13. (defun C:AUTOLOG ()
  14. ; the following is an error-trapping routine for hatching
  15.   (defun hatch ()
  16.     (setq hatyes 0)
  17.        (cond
  18.           ((= hatyes 0)
  19.             (setq pat(getstring "\nHatch Pattern: "))
  20.             (hatchit)
  21.           );end this case
  22.           ((= hatyes 2)
  23.              (prompt "\nNot Found!..Try Again")
  24.              (setq pat(getstring "\nHatch Pattern: "))
  25.              (hatchit)
  26.           );end this case
  27.        );end cond
  28.     );defun
  29. ;hatching subroutine
  30.    (defun hatchit ()
  31.           (cond             
  32.                    ((or (= pat "ar-conc") (= pat "AR-CONC"))
  33.                    (setq pscala 0.04)
  34.                    (command "hatch" pat pscala "" (entlast) "")        
  35.                    (setq hatyes 1)
  36.                 );end this case
  37.                    ((or (= pat "ar-b816") (= pat "AR-B816"))
  38.                    (setq pscala 0.04)
  39.                    (command "hatch" pat pscala "" (entlast) "")        
  40.                    (setq hatyes 1)
  41.                 );end this case
  42.                    ((or (= pat "ar-b816c") (= pat "AR-B816C"))
  43.                    (setq pscala 0.04)
  44.                    (command "hatch" pat pscala "" (entlast) "")        
  45.                    (setq hatyes 1)
  46.                 );end this case
  47.                    ((or (= pat "ar-b88") (= pat "AR-B88"))
  48.                    (setq pscala 0.04)
  49.                    (command "hatch" pat pscala "" (entlast) "")        
  50.                    (setq hatyes 1)
  51.                 );end this case
  52.                    ((or (= pat "ar-brelm") (= pat "AR-BRELM"))
  53.                    (setq pscala 0.04)
  54.                    (command "hatch" pat pscala "" (entlast) "")        
  55.                    (setq hatyes 1)
  56.                 );end this case
  57.                    ((or (= pat "ar-brstd") (= pat "AR-BRSTD"))
  58.                    (setq pscala 0.04)
  59.                    (command "hatch" pat pscala "" (entlast) "")        
  60.                    (setq hatyes 1)
  61.                 );end this case
  62.                    ((or (= pat "ar-hbone") (= pat "AR-HBONE"))
  63.                    (setq pscala 0.04)
  64.                    (command "hatch" pat pscala "" (entlast) "")        
  65.                    (setq hatyes 1)
  66.                 );end this case
  67.                    ((or (= pat "ar-parq1") (= pat "AR-PARQ1"))
  68.                    (setq pscala 0.04)
  69.                    (command "hatch" pat pscala "" (entlast) "")        
  70.                    (setq hatyes 1)
  71.                 );end this case
  72.                    ((or (= pat "ar-rroof") (= pat "AR-RROOF"))
  73.                    (setq pscala 0.04)
  74.                    (command "hatch" pat pscala "" (entlast) "")        
  75.                    (setq hatyes 1)
  76.                 );end this case
  77.                    ((or (= pat "ar-rshke") (= pat "AR-RSHKE"))
  78.                    (setq pscala 0.04)
  79.                    (command "hatch" pat pscala "" (entlast) "")        
  80.                    (setq hatyes 1)
  81.                 );end this case
  82.                    ((or (= pat "box") (= pat "BOX"))
  83.                    (setq pscala 0.04)
  84.                    (command "hatch" pat pscala "" (entlast) "")        
  85.                    (setq hatyes 1)
  86.                 );end this case
  87.                    ((or (= pat "brass") (= pat "BRASS"))
  88.                    (setq pscala 0.04)
  89.                    (command "hatch" pat pscala "" (entlast) "")        
  90.                    (setq hatyes 1)
  91.                 );end this case
  92.                    ((or (= pat "brstone") (= pat "BRSTONE"))
  93.                    (setq pscala 0.04)
  94.                    (command "hatch" pat pscala "" (entlast) "")        
  95.                    (setq hatyes 1)
  96.                 );end this case
  97.                    ((or (= pat "cork") (= pat "CORK"))
  98.                    (setq pscala 1)
  99.                    (command "hatch" pat pscala "" (entlast) "")        
  100.                    (setq hatyes 1)
  101.                 );end this case
  102.                    ((or (= pat "earth") (= pat "EARTH"))
  103.                    (setq pscala 1)
  104.                    (command "hatch" pat pscala "" (entlast) "")        
  105.                    (setq hatyes 1)
  106.                 );end this case
  107.                    ((or (= pat "escher") (= pat "ESCHER"))
  108.                    (setq pscala 0.1)
  109.                    (command "hatch" pat pscala "" (entlast) "")        
  110.                    (setq hatyes 1)
  111.                 );end this case
  112.                    ((or (= pat "flex") (= pat "FLEX"))
  113.                    (setq pscala 0.04)
  114.                    (command "hatch" pat pscala "" (entlast) "")        
  115.                    (setq hatyes 1)
  116.                 );end this case
  117.                    ((or (= pat "grass") (= pat "GRASS"))
  118.                    (setq pscala 0.04)
  119.                    (command "hatch" pat pscala "" (entlast) "")        
  120.                    (setq hatyes 1)
  121.                 );end this case
  122.                    ((or (= pat "grate") (= pat "GRATE"))
  123.                    (setq pscala 0.04)
  124.                    (command "hatch" pat pscala "" (entlast) "")        
  125.                    (setq hatyes 1)
  126.                 );end this case
  127.                    ((or (= pat "hex") (= pat "HEX"))
  128.                    (setq pscala 0.04)
  129.                    (command "hatch" pat pscala "" (entlast) "")        
  130.                    (setq hatyes 1)
  131.                 );end this case
  132.                    ((or (= pat "honey") (= pat "HONEY"))
  133.                    (setq pscala 0.04)
  134.                    (command "hatch" pat pscala "" (entlast) "")        
  135.                    (setq hatyes 1)
  136.                 );end this case
  137.                    ((or (= pat "hound") (= pat "HOUND"))
  138.                    (setq pscala 0.04)
  139.                    (command "hatch" pat pscala "" (entlast) "")        
  140.                    (setq hatyes 1)
  141.                 );end this case
  142.                    ((or (= pat "INSUL") (= pat "insul"))
  143.                    (setq pscala 0.04)
  144.                    (command "hatch" pat pscala "" (entlast) "")        
  145.                    (setq hatyes 1)
  146.                 );end this case
  147.                    ((or (= pat "line") (= pat "LINE"))
  148.                    (setq pscala 0.04)
  149.                    (command "hatch" pat pscala "" (entlast) "")        
  150.                    (setq hatyes 1)
  151.                 );end this case
  152.                    ((or (= pat "NET") (= pat "net"))
  153.                    (setq pscala 0.04)
  154.                    (command "hatch" pat pscala "" (entlast) "")        
  155.                    (setq hatyes 1)
  156.                 );end this case
  157.                    ((or (= pat "net3") (= pat "NET3"))
  158.                    (setq pscala 0.04)
  159.                    (command "hatch" pat pscala "" (entlast) "")        
  160.                    (setq hatyes 1)
  161.                 );end this case
  162.                    ((or (= pat "PLAST") (= pat "plast"))
  163.                    (setq pscala 0.04)
  164.                    (command "hatch" pat pscala "" (entlast) "")        
  165.                    (setq hatyes 1)
  166.                 );end this case
  167.                    ((or (= pat "plasti") (= pat "PLASTI"))
  168.                    (setq pscala 0.04)
  169.                    (command "hatch" pat pscala "" (entlast) "")        
  170.                    (setq hatyes 1)
  171.                 );end this case
  172.                    ((or (= pat "sacncr") (= pat "SACNCR"))
  173.                    (setq pscala 0.04)
  174.                    (command "hatch" pat pscala "" (entlast) "")        
  175.                    (setq hatyes 1)
  176.                 );end this case
  177.                    ((or (= pat "SQUARE") (= pat "square"))
  178.                    (setq pscala 0.04)
  179.                    (command "hatch" pat pscala "" (entlast) "")        
  180.                    (setq hatyes 1)
  181.                 );end this case
  182.                    ((or (= pat "stars") (= pat "STARS"))
  183.                    (setq pscala 0.04)
  184.                    (command "hatch" pat pscala "" (entlast) "")        
  185.                    (setq hatyes 1)
  186.                 );end this case
  187.                    ((or (= pat "STEEL") (= pat "steel"))
  188.                    (setq pscala 0.04)
  189.                    (command "hatch" pat pscala "" (entlast) "")        
  190.                    (setq hatyes 1)
  191.                 );end this case
  192.                    ((or (= pat "swamp") (= pat "SWAMP"))
  193.                    (setq pscala 0.04)
  194.                    (command "hatch" pat pscala "" (entlast) "")        
  195.                    (setq hatyes 1)
  196.                 );end this case
  197.                    ((or (= pat "trans") (= pat "TRANS"))
  198.                    (setq pscala 0.04)
  199.                    (command "hatch" pat pscala "" (entlast) "")        
  200.                    (setq hatyes 1)
  201.                 );end this case
  202.                    ((or (= pat "TRIANG") (= pat "triang"))
  203.                    (setq pscala 0.04)
  204.                    (command "hatch" pat pscala "" (entlast) "")        
  205.                    (setq hatyes 1)
  206.                 );end this case
  207.                    ((or (= pat "zigzag") (= pat "ZIGZAG"))
  208.                    (setq pscala 0.04)
  209.                    (command "hatch" pat pscala "" (entlast) "")        
  210.                    (setq hatyes 1)
  211.                 );end this case
  212.                    ((or (= pat "dots") (= pat "DOTS"))
  213.                    (setq pscala 1)
  214.                    (command "hatch" pat pscala "" (entlast) "")
  215.                    (setq hatyes 1)
  216.                 );end this case
  217.                    ((or (= pat "dolmit") (= pat "DOLMIT"))
  218.                    (setq pscala 1)
  219.                    (command "hatch" pat pscala "" (entlast) "")
  220.                    (setq hatyes 1)
  221.                 );end this case
  222.                    ((or (= pat "u") (= pat "U"))
  223.                    (setq pscala 0.1)
  224.                    (command "hatch" pat "" pscala "" (entlast) "")
  225.                    (setq hatyes 1)
  226.                 );end this case
  227.                    ((or (= pat "mudst") (= pat "MUDST"))
  228.                    (setq pscala 0.5)
  229.                    (command "hatch" pat pscala "" (entlast) "")
  230.                    (setq hatyes 1)
  231.                 );end this case
  232.                    ((or (= pat "ar-sand") (= pat "AR-SAND"))
  233.                    (setq pscala 0.06)
  234.                    (command "hatch" pat pscala "" (entlast) "")
  235.                    (setq hatyes 1)
  236.                 );end this case
  237.                    ((or (= pat "brick") (= pat "BRICK"))
  238.                    (setq pscala 1)
  239.                    (command "hatch" pat pscala "" (entlast) "")
  240.                    (setq hatyes 1)
  241.                 );end this case
  242.                    ((or (= pat "cross") (= pat "CROSS"))
  243.                    (setq pscala 1)
  244.                    (command "hatch" pat pscala "" (entlast) "")
  245.                    (setq hatyes 1)
  246.                 );end this case          
  247.                    ((or (= pat "clay") (= pat "CLAY"))
  248.                    (setq pscalai 2)
  249.                    (command "hatch" pat pscala "" (entlast) "")
  250.                    (setq hatyes 1)
  251.                 );end this case
  252.                    ((or (= pat "angle") (= pat "ANGLE"))
  253.                    (setq pscala 2)
  254.                    (command "hatch" pat pscala "" (entlast) "")
  255.                    (setq hatyes 1)
  256.                 );end this case
  257.                    ((or (= pat "ANSI31") (= pat "ansi31"))
  258.                    (setq pscala 2)
  259.                    (command "hatch" pat pscala "" (entlast) "")
  260.                    (setq hatyes 1)
  261.                 );end this case
  262.                    ((or (= pat "ansi32") (= pat "ANSI32"))
  263.                    (setq pscala 2)
  264.                    (command "hatch" pat pscala "" (entlast) "")
  265.                    (setq hatyes 1)
  266.                 );end this case
  267.                    ((or (= pat "ANSI33") (= pat "ansi33"))
  268.                    (setq pscala 2)
  269.                    (command "hatch" pat pscala "" (entlast) "")
  270.                    (setq hatyes 1)
  271.                 );end this case
  272.                    ((or (= pat "ANSI34") (= pat "ansi34"))
  273.                    (setq pscala 2)
  274.                    (command "hatch" pat pscala "" (entlast) "")
  275.                    (setq hatyes 1)
  276.                 );end this case
  277.                    ((or (= pat "ANSI35") (= pat "ansi35"))
  278.                    (setq pscala 2)
  279.                    (command "hatch" pat pscala "" (entlast) "")
  280.                    (setq hatyes 1)
  281.                 );end this case
  282.                    ((or (= pat "ANSI36") (= pat "ansi36"))
  283.                    (setq pscala 2)
  284.                    (command "hatch" pat pscala "" (entlast) "")
  285.                    (setq hatyes 1)
  286.                 );end this case
  287.                    ((or (= pat "ANSI37") (= pat "ansi37"))
  288.                    (setq pscala 2)
  289.                    (command "hatch" pat pscala "" (entlast) "")
  290.                    (setq hatyes 1)
  291.                 );end this case
  292.                    ((or (= pat "ANSI38") (= pat "ansi38"))
  293.                    (setq pscala 2)
  294.                    (command "hatch" pat pscala "" (entlast) "")
  295.                    (setq hatyes 1)
  296.                 );end this case
  297.                    ((or (= pat "dash") (= pat "DASH"))
  298.                    (setq pscala 1)
  299.                    (command "hatch" pat pscala "" (entlast) "")
  300.                    (setq hatyes 1)
  301.                 );end this case
  302.                   ((= hatyes 0)
  303.                   (setq hatyes 2)
  304.                   (prompt "\nNot Found!..Try Again")
  305.                   (hatch)
  306.                 );end this cond
  307.             ):end cond
  308.        );end defun
  309. (command "limits" "-5,-5" "20,20")
  310. (command "zoom" "all")
  311. ;(command "setvar" "cmdecho" "0")
  312. (command "pline" "0,8" "8.5,8" "");draws ground surface
  313. (command "style" "b" "romans" ".07" "" "" "" "" "" "");sets style for well construction label
  314. (command "pline" "0,0" "0,11" "8.5,11" "8.5,0" "0,0" "");draws box
  315. (setq linelabel 4.65)
  316. ;
  317. ; **** Get overall depth and scale it.
  318. ;
  319. (setq totald(getreal "\nEnter total depth: "));**** obtain overall depth*
  320. (setq scale(/ totald 7))
  321. ;
  322. ; **** Get overall width and scale it.
  323. ;
  324. (setq totalw(getreal "\nEnter total width: "));**** obtain overal width**
  325. (setq scalew(/ totalw 2)); changed from 2.5 -> 2
  326. ;
  327. ;   ***********     This section draws the boreholes    *************
  328. ;
  329. (setq borings(getint "\nEnter total number of borings: "))
  330.      (if (= borings 1);       **** IF test statement ****  
  331. ;
  332. ;      ************** PROGN for a single boring ***************
  333. ;
  334.         (progn
  335.            (setq boringwidth(getreal "\nEnter boring diameter: "))
  336.            (setq garbage (/ boringwidth scalew)) ; **** xr is scale for right side ****
  337.            (setq offset (/ garbage 2))
  338.            (setq xl (- 6.5 offset))
  339.            (setq xr (+ 6.5 offset))
  340.            (setq boringdepth(getreal "\nEnter boring depth: "))
  341.            (setq scaled (/ boringdepth scale))
  342.            (setq yl (- 8 scaled))
  343.            (setq yu 8)  
  344.            (setq ul(list xl yu))
  345.            (setq ur(list xr yu));        **** upper  right of inner casing ****
  346.            (setq ll(list xl yl));          **** lower left of inner casing **** 
  347.            (setq lr(list xr yl));         **** lower right of inner casing **** 
  348.            (command "pline" ul ur lr ll "c");      **** draws inner casing ****
  349.            ;  ***** (hatch)                       **** calls hatching sub ****    
  350.            ; **** LABEL FOR BORING ****
  351.            (prompt "\nLabel for Boring: ")
  352.            (setq borelabel(read-line))
  353.            (setq midy (/ scaled 2));      **** these two lines find the middle
  354.            (setq midy (- yu midy));     **** of the casing in the y direction
  355.            (setq midxyr(list xl midy));   **** assigns xy for start of line ****
  356.            (setq midxyl(list linelabel midy)) 
  357.            (command "line" midxyr midxyl ""); draws line to casing label
  358.            (setq try (- midy 0.035)); finds y starting point for text
  359.            (setq trx (- xl 0.9)); finds x starting point for text
  360.            (setq tstart(list trx try))
  361.            (command "text" "j" "r" tstart "0" borelabel) ;adds casing label      
  362.          ); **** end paren for progn ****
  363. ;
  364. ;      ******** PROGN for multiple borings *********
  365. ;    **** first block of code handles first boring ****
  366. ;
  367.         (progn
  368.            (setq boringwidth(getreal "\nEnter first boring diameter: "))
  369.            (setq meso (/ boringwidth scalew)) ; **** xr is scale for right side ****
  370.            (setq garbage (/ meso 2))
  371.            (setq xl (- 6.5 garbage))
  372.            (setq xr (+ 6.5 garbage))
  373.            (setq boringdepth(getreal "\nEnter first boring depth: "))
  374.            (setq scaled(/ boringdepth scale))
  375.            (setq yl (- 8 scaled))
  376.            (setq yu 8)  
  377.            (setq ul(list xl yu))
  378.            (setq ur(list xr yu));        **** upper  right of inner casing ****
  379.            (setq ll(list xl yl));          **** lower left of inner casing **** 
  380.            (setq lr(list xr yl));         **** lower right of inner casing **** 
  381.            (command "line" ul ur "") 
  382.            (command "line" ll ul "")
  383.            (command "line" lr ur "")
  384.            (setq runl ll)
  385.            (setq runr lr)
  386. ;
  387.            ;***** (hatch);                        **** calls hatching sub ****    
  388.            ; **** LABEL FOR BORING ****
  389.            (prompt "\nLabel for Boring: ")
  390.            (setq borelabel(read-line))
  391.            (setq midy (/ scaled 2));      **** these two lines find the middle
  392.            (setq midy (- yu midy));     **** of the casing in the y direction
  393.            (setq midxyr(list xl midy));   **** assigns xy for start of line ****
  394.            (setq midxyl(list linelabel midy)) 
  395.            (command "line" midxyr midxyl ""); draws line to casing label
  396.            (setq try (- midy 0.035)); finds y starting point for text
  397.            (setq trx (- xl 0.9)); finds x starting point for text
  398.            (setq tstart(list trx try))
  399.            (command "text" "j" "r" tstart "0" borelabel) ;adds casing label      
  400.            (setq borings(- borings 1));   **** subtract one -> one is done ****        
  401. ;
  402. ;     ********   REPEAT loop to handle the rest of the borings   *********
  403. ;
  404. (setq runyu yl) ; running depth  -->  scaled
  405.            (repeat borings        ; DEBUG --> this may need a paren
  406.               (setq boringwidth(getreal "\nEnter boring diameter: "))
  407.               (setq garbage (/ boringwidth scalew)) ; **** xr is scale for right side ****
  408.               (setq offset (/ garbage 2))
  409.               (setq xl (- 6.5 offset))
  410.               (setq xr (+ 6.5 offset))
  411.               (setq boringdepth(getreal "\nEnter boring depth: "))
  412.               (setq scaled(/ boringdepth scale))
  413.               (setq yl (- runyu scaled))       
  414.               (setq yu runyu)
  415.               (setq ul(list xl yu))
  416.               (setq ur(list xr yu));        **** upper  right of inner casing ****
  417.               (setq ll(list xl yl));          **** lower left of inner casing **** 
  418.               (setq lr(list xr yl));         **** lower right of inner casing **** 
  419.               (command "line" ll ul "")
  420.               (command "line" lr ur "")
  421.               (command "line" runl ul "")
  422.               (command "line" runr ur "")
  423.               ; **** LABEL FOR BORING ****
  424.               (prompt "\nLabel for Boring: ")
  425.               (setq borelabel(read-line))
  426.               (setq midy (/ scaled 2));      **** these two lines find the middle
  427.               (setq midy (- yu midy));     **** of the casing in the y direction
  428.               (setq midxyr(list xl midy));   **** assigns xy for start of line ****
  429.               (setq midxyl(list linelabel midy)) 
  430.               (command "line" midxyr midxyl ""); draws line to casing label
  431.               (setq try (- midy 0.035)); finds y starting point for text
  432.               (setq trx (- linelabel 0.05)); finds x starting point for text
  433.               (setq tstart(list trx try))
  434. ; browneye - borelabel
  435.               (command "text" "j" "r" tstart "0" borelabel) ;adds casing label      
  436. ; The following handles line drawing and other running variables      
  437.               (setq runl ll)
  438.               (setq runr lr)
  439.               (setq runyu yl)
  440.             ); **** end paren for repeat ****
  441.           (command "line" ll lr "")
  442.          ); **** end paren for progn ****
  443.       ); **** end paren for if loop
  444.    (setq boringxl xl); **** These two lines carry the value of the
  445.    (setq boringxr xr); **** final boring width to the sand part
  446. ;
  447. ;******* end of borehole section **********
  448. ;
  449. ;***********  CASING IF LOOP ****************
  450. ;
  451. ;
  452. (setq caseno(getint "\nEnter total number of casings: "))
  453.    (if (= caseno 1);      **** IF test statement **** 
  454. ;
  455. ;   **** FIRST PROGN IS FOR A SINGLE CASING WELL ONLY ****
  456. ;
  457.      (progn     
  458.       (setq casewidth(getreal "\nEnter casing diameter: "))
  459.       (setq garbage (/ casewidth scalew))
  460.       (setq offset (/ garbage 2))
  461.       (setq xl (- 6.5 offset)); xl = x left
  462.       (setq xr (+ 6.5 offset)); xr = x right
  463. ;   
  464. ;       <------**** Set xl & xr for screen ****------->
  465. ;
  466.      (setq screenxl xl)
  467.      (setq screenxr xr)
  468. ;
  469. ;
  470.       (setq casedepth(getreal "\nEnter casing depth: "))
  471.       (setq scaled(/ casedepth scale)) ;
  472.       (setq yl (- 8 scaled));   **** yl is scaled variable for bottom of casing ****
  473.       (setq yu 8);            **** constant for top left of well ****
  474.       (setq ul(list xl yu));  **** upper left of inner casing ****
  475.       (setq ur(list xr yu));  **** upper  right of inner casing ****
  476.       (setq ll(list xl yl));  **** lower left of inner casing **** 
  477.       (setq lr(list xr yl));  **** lower right of inner casing **** 
  478.       (command "pline" ul ur lr ll "c");                 **** draws inner casing ****
  479.       ; **** LABEL FOR CASING ****
  480.       (prompt "\nLabel for Casing: ")
  481.       (setq caselabel(read-line))
  482.       (setq midy (/ scaled 2));      **** these two lines find the middle
  483.       (setq midy (- yu midy));     **** of the casing in the y direction
  484.       (setq midxyr(list xl midy));   **** assigns xy for start of line ****
  485.       (setq midxyl(list linelabel midy)) 
  486.       (command "line" midxyr midxyl ""); draws line to casing label
  487.       (setq try (- midy 0.035)); finds y starting point for text
  488.       (setq tstart(list trx try))
  489.       (command "text" "j" "r" tstart "0" caselabel) ;adds casing label      
  490. ;
  491.   (setq casingxl xl); **** These variable carry the value of the final
  492.   (setq casingxr xr); **** casing width to the sand part
  493. ;
  494. ;<------------------------------------------------------------->
  495. ;****------------------>   Well stick up  <-----------------****
  496. ;<------------------------------------------------------------->
  497. ;
  498.    (setq stickll ul);  These two lines transfer the value from
  499.    (setq sticklr ur); the above fragment to establish the bottom of
  500. ;                       the stick-up
  501. ;
  502.    (setq stickup(getreal "\nEnter well stick up: ")); Gets stick-up height
  503.    (setq scaled(/ stickup scale)) ;
  504.    (setq stickup(+ scaled yu))
  505.    (setq stickul(list xl stickup));      **** upper left of stick up ****
  506.    (setq stickur(list xr stickup));     **** upper  right of stick up ****
  507.    (command "line" stickll stickul "")
  508.    (command "line" stickul stickur "")
  509.    (command "line" stickur sticklr "")
  510. ;
  511. ;<------------------------------------------------------------->
  512. ;****--------------->   Protective casing <-----------------****
  513. ;<------------------------------------------------------------->
  514. ;
  515.    (setq protabove (getreal "\nHow far above the ground does the protctive casing go "))
  516.    (setq protbelow (getreal "\nHow far below the ground does the protctive casing go "))
  517.    (setq protwid (getreal "\nHow wide is the protective casing: "))
  518.    (setq garbage (/ protwid scalew))
  519.    (setq offset (/ garbage 2))
  520. ;
  521. ;       <------**** Establish Knowns ****------->
  522. ;
  523.    (setq xl (- 6.5 offset)); xl = x left
  524.    (setq xr (+ 6.5 offset)); xr = x right
  525.    (setq ground 8);       **** constant for ground ****
  526. ; **** find scaled lower limits of prot. casing and draw it ****
  527. ;
  528.    (setq scaled(/ protbelow scale)) ;
  529.    (setq protbelow (- 8 scaled));   **** yl is scaled variable for bottom of casing ****
  530. ;     ***** DRAW IT ****
  531.    (setq protll (list xl protbelow))
  532.    (setq protlr (list xr protbelow)) 
  533.    (setq protur (list xr ground))
  534.    (setq protul (list xl ground))
  535.    (command "line" protll protul "")
  536.    (command "line" protlr protur "")
  537. ;
  538. ;**** find scaled upper limits of prot. casing and draw it ****
  539. ;
  540.    (setq scaled(/ protabove scale)) ;
  541.    (setq protabove (+ 8 scaled));   **** yl is scaled variable for bottom of casing ****
  542.    (setq protll (list xl ground))
  543.    (setq protlr (list xr ground))
  544.    (setq protur (list xr protabove))
  545.    (setq protul (list xl protabove))
  546.    (command "line" protll protul "")
  547.    (command "line" protur protul "")
  548.    (command "line" protlr protur "")
  549. ;
  550.      ); ends progn 
  551. ;
  552. ;   **** This progn handles the first casing  and has an imbedded ****
  553. ;   **** repeat loop to handle subsequent casings.                ****
  554. ;
  555.     (progn
  556.       (prompt "\nThe first casing is the outermost (widest) casing"); DEBUG parens in text
  557.       (setq casewidth(getreal "\nEnter first casing diameter: "))
  558.       (setq garbage (/ casewidth scalew))
  559.       (setq offset (/ garbage 2))
  560.       (setq xl (- 6.5 offset))
  561.       (setq xr (+ 6.5 offset))
  562.       (setq casedepth(getreal "\nEnter first casing depth: "))
  563.       (setq scaled(/ casedepth scale)) ;
  564.       (setq yl (- 8 scaled));         **** yl is scaled variable for bottom of casing ****
  565.       (setq yu 8);                            **** constant for top left of well ****
  566.       (setq ul(list xl yu));                     **** upper left of inner casing ****
  567.       (setq ur(list xr yu));                   **** upper  right of inner casing ****
  568.       (setq ll(list xl yl));                     **** lower left of inner casing **** 
  569.       (setq lr(list xr yl));                    **** lower right of inner casing **** 
  570.       (command "line" ul ur "") 
  571.       (command "line" ll ul "")
  572.       (command "line" lr ur "")
  573.       (setq runl ll)
  574.       (setq runr lr)
  575.       ; **** LABEL FOR CASING ****
  576.       (prompt "\nLabel for Casing: ")
  577.       (setq caselabel(read-line))
  578.       (setq midy (/ scaled 2));      **** these two lines find the middle
  579.       (setq midy (- yu midy));     **** of the casing in the y direction
  580.       (setq midxyr(list xl midy));   **** assigns xy for start of line ****
  581.       (setq midxyl(list linelabel midy)) 
  582.       (command "line" midxyr midxyl ""); draws line to casing label
  583.       (setq try (- midy 0.035)); finds y starting point for text
  584.       (setq tstart(list trx try))
  585.       (command "text" "j" "r" tstart "0" caselabel) ;adds casing label      
  586.       (setq caseno(- caseno 1));   **** subtract one -> one is done ****        
  587. ;
  588. ;<---------**** REPEAT loop for the rest of casings ****------------>
  589. ;
  590.            (setq runyu yl) ; running depth  -->  scaled
  591. ;
  592. ;
  593.            (repeat caseno
  594.            (setq runyu yl)
  595.            (setq casewidth(getreal "\nEnter casing diameter: "))
  596.            (setq garbage (/ casewidth scalew))
  597.            (setq offset (/ garbage 2))
  598.            (setq xl (- 6.5 offset))
  599.            (setq xr (+ 6.5 offset))
  600.            (setq casedepth(getreal "\nEnter casing depth: "))
  601.            (setq scaled(/ casedepth scale)) ;
  602.            (setq yl (- runyu scaled))       
  603.            (setq yu runyu)
  604.            (setq ul(list xl yu));          **** upper left of inner casing ****
  605.            (setq ur(list xr yu));        **** upper  right of inner casing ****
  606.            (setq ll(list xl yl));          **** lower left of inner casing **** 
  607.            (setq lr(list xr yl));         **** lower right of inner casing **** 
  608.            (command "line" ul ll "")
  609.            (command "line" lr ur "")
  610.            (command "line" runl ul "")
  611.            (command "line" runr ur "")
  612.            ; **** LABEL FOR CASING ****
  613.            (prompt "\nLabel for Casing: ")
  614.            (setq caselabel(read-line))
  615.            (setq midy (/ scaled 2));      **** these two lines find the middle
  616.            (setq midy (- yu midy));     **** of the casing in the y direction
  617.            (setq midxyr(list xl midy));   **** assigns xy for start of line ****
  618.            (setq midxyl(list linelabel midy)) 
  619.            (command "line" midxyr midxyl ""); draws line to casing label
  620.            (setq try (- midy 0.035)); finds y starting point for text
  621.            (setq tstart(list trx try))
  622.            (command "text" "j" "r" tstart "0" caselabel) ;adds casing label      
  623.            (setq runyu yl)
  624.            (setq runl ll)
  625.            (setq runr lr)
  626. ;
  627.            ); ENDS REPEAT
  628.         (setq ytop 8)        
  629.         (setq topl (list xl ytop));  **** this group of code will extend
  630.         (setq topr (list xr ytop));  **** the innermost casing to the surface
  631.         (setq botl (list xl yu))
  632.         (setq botr (list xr yu));  **** yu takes the y upper from loop
  633.         (command "line" topl botl "")
  634.         (command "line" topr botr "")
  635.         (command "line" ll lr "")
  636. ;   
  637. ;       <------**** Set xl & xr for screen ****------->
  638. ;
  639.   (setq casingxl xl); **** These variable carry the value of the final
  640.   (setq casingxr xr); **** casing width to the sand part
  641. ;
  642.      (setq xl screenxl)
  643.      (setq xr screenxr)
  644. ;
  645. ;
  646. ;
  647. ;
  648. ;<------------------------------------------------------------->
  649. ;****------------------>   Well stick up  <-----------------****
  650. ;<------------------------------------------------------------->
  651. ;
  652.    (setq stickll topl);  These two lines transfer the value from
  653.    (setq sticklr topr); the above fragment to establish the bottom of
  654. ;                       the stick-up
  655. ;
  656.    (setq stickup(getreal "\nEnter well stick up: ")); Gets stick-up height
  657.    (setq scaled(/ stickup scale)) ;
  658.    (setq stickup(+ scaled ytop))
  659.    (setq stickul(list xl stickup));      **** upper left of stick up ****
  660.    (setq stickur(list xr stickup));     **** upper  right of stick up ****
  661.    (command "line" stickll stickul "")
  662.    (command "line" stickul stickur "")
  663.    (command "line" stickur sticklr "")
  664. ;
  665. ;<------------------------------------------------------------->
  666. ;****--------------->   Protective casing <-----------------****
  667. ;<------------------------------------------------------------->
  668. ;
  669.    (setq protabove (getreal "\nHow far above the ground does the protctive casing go "))
  670.    (setq protbelow (getreal "\nHow far below the ground does the protctive casing go "))
  671.    (setq protwid (getreal "\nHow wide is the protective casing: "))
  672.    (setq garbage (/ protwid scalew))
  673.    (setq offset (/ garbage 2))
  674. ;
  675. ;       <------**** Establish Knowns ****------->
  676. ;
  677.    (setq xl (- 6.5 offset)); xl = x left
  678.    (setq xr (+ 6.5 offset)); xr = x right
  679.    (setq ground 8);       **** constant for ground ****
  680. ;
  681. ; **** find scaled lower limits of prot. casing and draw it ****
  682. ;
  683.    (setq scaled(/ protbelow scale)) ;
  684.    (setq protbelow (- 8 scaled));   **** yl is scaled variable for bottom of casing ****
  685. ;     ***** DRAW IT ****
  686.    (setq protll (list xl protbelow))
  687.    (setq protlr (list xr protbelow)) 
  688.    (setq protur (list xr ground))
  689.    (setq protul (list xl ground))
  690.    (command "line" protll protul "")
  691.    (command "line" protlr protur "")
  692. ;
  693. ;**** find scaled upper limits of prot. casing and draw it ****
  694. ;
  695.    (setq scaled(/ protabove scale)) ;
  696.    (setq protabove (+ 8 scaled));   **** yl is scaled variable for bottom of casing ****
  697.    (setq protll (list xl ground))
  698.    (setq protlr (list xr ground))
  699.    (setq protur (list xr protabove))
  700.    (setq protul (list xl protabove))
  701.    (command "line" protll protul "")
  702.    (command "line" protur protul "")
  703.    (command "line" protlr protur "")
  704. ;
  705. ;
  706.       ); ENDS PROGN
  707.    ); ENDS IF
  708. ;
  709. ; **** This section adds things like the screen, the sand pack and the
  710. ; **** bentonite seal so that the well is fairly complete here
  711. ;
  712. ;
  713. ;<------------------------------------------------------------->
  714. ;****--------------->     Well screen     <-----------------****
  715. ;<------------------------------------------------------------->
  716. ;
  717. ;
  718. ;
  719. (setq screendep(getreal "\nEnter the depth to the top of the screen: "))
  720. (setq screenint(getreal "\nEnter the height of the screen: "))
  721. (setq totop(/ screendep scale)) ; scaled distance to screen top!!!
  722. (setq scrwid(/ screenint scale)); scaled screen height!!!
  723. (setq screentop(- 8 totop)); top of screen
  724. (setq screenbot(- screentop scrwid)); bottom of screen
  725. (setq ul(list screenxl screentop))
  726. (setq ur(list screenxr screentop))
  727. (setq ll(list screenxl screenbot))
  728. (setq lr(list screenxr screenbot))
  729. (command "pline" ul ll lr ur "c"); Draws screen
  730. (hatch); calls hatching sub
  731. (setq halfdep(/ scrwid 2))
  732. (setq screenmid(- screentop halfdep))
  733. (setq midxyr(list screenxl screenmid)) 
  734. (setq midxyl(list linelabel screenmid)) 
  735. (command "line" midxyr midxyl ""); draws line to casing label
  736. (prompt "\nLabel for Screen: ")
  737. (setq scrlabel(read-line))
  738. (setq try (- screenmid 0.035)); finds y starting point for text
  739. ;(setq trx (- screenxl 0.9)); finds x starting point for text 
  740. (setq tstart(list trx try))
  741. (command "text" "j" "r" tstart "0" scrlabel) ;adds screen label      
  742. ;
  743. ; **** End of screen section
  744. ;
  745. ;
  746. ;<--------------------------------------------------------->
  747. ;****------>  This section is for the Sandpack <-------****
  748. ;<--------------------------------------------------------->;
  749. ;
  750. (setq ans (getstring "\nIs there any sand in the well? (y or n) "))
  751. (if (= ans "y");      **** IF test statement **** 
  752. (progn
  753. (setq sanddep(getreal "\nEnter the depth to the top of the sand: "))
  754. (setq deptotop(/ sanddep scale)) ; scaled distance to sand top!!!
  755. (setq sandtop(- 8 deptotop)); top of sand in page units.!!!!
  756. ; **** Next line finds interval
  757. (setq sandint(getreal "\nEnter the thickness of the sand: "))
  758. (setq sandwid(/ sandint scale)); scaled sand height!!!
  759. (setq sandbot(- sandtop sandwid)); bottom of sand
  760. ;
  761.  (setq xl boringxl)
  762.  (setq xr casingxl)
  763. ;
  764. ; **** First do left side of well ****
  765. ;
  766. (setq ul(list xl sandtop))
  767. (setq ur(list xr sandtop))
  768. (setq ll(list xl sandbot))
  769. (setq lr(list xr sandbot))
  770. (command "pline" ul ll lr ur "c"); Draws extents of sand
  771. ;(hatch); calls hatching sub
  772. (command "hatch" pat "" pscala (entlast) "")        
  773. (setq halfdep(/ sandwid 2))
  774. (setq sandmid(- sandtop halfdep))
  775. (setq midxyr(list xl sandmid)) 
  776. (setq midxyl(list linelabel sandmid)) 
  777. (command "line" midxyr midxyl ""); draws line to casing label
  778. (prompt "\nLabel for Sand: ")
  779. (setq sandlabel(read-line))
  780. (setq try (- sandmid 0.035)); finds y starting point for text
  781. (setq trx (- xl 0.9)); finds x starting point for text
  782. (setq tstart(list trx try))
  783. (command "text" "j" "r" tstart "0" sandlabel) ;adds sand label      
  784. ;
  785. ;
  786. ; **** Now the right side ****
  787. ;
  788. (setq xr boringxr); these two lines set up the x coords.
  789. (setq xl casingxr)
  790. ;
  791. (setq ul(list xl sandtop))
  792. (setq ur(list xr sandtop))
  793. (setq ll(list xl sandbot))
  794. (setq lr(list xr sandbot))
  795. (command "pline" ul ll lr ur "c"); Draws extents of sand
  796. (command "hatch" pat "" pscala (entlast) "")        
  797. ;
  798. ); progn
  799. ); ends if
  800. ; <--------------------------------------------------------->
  801. ; ****---->  This section is for the Bentonite seal <----****
  802. ; <--------------------------------------------------------->
  803. ;
  804. (setq ans (getstring "\nIs there a bentonite seal (y or n): "))
  805. (if (= ans "y");      **** IF test statement **** 
  806. (progn
  807.   (setq benthick(getreal "\nEnter Thickness of bentonite seal: "))
  808.   (setq benthicks(/ benthick scale)) ; **** scaled bentonite thickness ****
  809. ;
  810. ;      **** Assign bentonite x and y values **** 
  811. ;     **** Using sandtop as bentonite bottom ****
  812. ;    **** Using previous widths for bentonite. ****
  813. ;
  814. (setq bentop (+ benthicks sandtop)); **** top of bentonite ****
  815. (setq benbot sandtop); **** bottom of bentonite ****
  816. ;
  817. ;
  818. ; **** First do left side of bentonite ****
  819. (setq xl boringxl); transfer values
  820. (setq xr casingxl)
  821. (setq ll(list xl benbot))
  822. (setq lr(list xr benbot))
  823. (setq ur(list xr bentop))
  824. (setq ul(list xl bentop))
  825. (command "pline" ul ll lr ur "c"); Draws extents of bentonite
  826. (hatch)
  827. ;
  828. ;**** Draw label and tick for bentonite ****
  829. ;
  830. (setq halfthick(/ benthicks 2))
  831. (setq benmid(- bentop halfthick))
  832. (setq midxyr(list xl benmid)) 
  833. (setq midxyl(list linelabel benmid)) 
  834. (command "line" midxyr midxyl ""); draws line to casing label
  835. (prompt "\nLabel for Bentonite: ")
  836. (setq benlabel(read-line))
  837. (setq try (- benmid 0.035)); finds y starting point for text
  838. (setq trx (- xl 0.9)); finds x starting point for text
  839. (setq tstart(list trx try))
  840. (command "text" "j" "r" tstart "0" benlabel) ;adds bentonite label      
  841. ;
  842. ; **** Now do right side of bentonite ****
  843. ;
  844. (setq xl boringxr); transfer values
  845. (setq xr casingxr)
  846. (setq ll(list xl benbot))
  847. (setq lr(list xr benbot))
  848. (setq ur(list xr bentop))
  849. (setq ul(list xl bentop))
  850. (command "pline" ul ll lr ur "c"); Draws extents of bentonite
  851. (command "hatch" pat "" pscala (entlast) "")
  852. ;
  853. ;
  854. );progn
  855. ); closes if
  856. ;<----------------------------------------------->
  857. ; ****------------->LITHOLOGY<----------------**** 
  858. ;<----------------------------------------------->
  859. ;
  860. (prompt "\nTHIS SECTION IS FOR GEOLOGIC LOG")
  861. (setq garbage(getstring "\nHit any key to continue..."))
  862. (command "move" "w" "0,0" "20,20" "" "1,1" "0,0")
  863. (setq a(getreal "\nThickness of layer: ")) 
  864. (setq thick(/ a scale))
  865. (setq x 0)
  866. (setq xr 1)
  867. (setq ul(list x thick))
  868. (setq ur(list xr thick)) 
  869. (command "pline" "0,0" ul ur "1,0" "c");draws first formation
  870. (hatch)
  871. (command "pline" ul ur "")
  872. (command "pedit" (entlast) "w" ".01" "")
  873. (command "style" "b" "romans" ".07" "" "" "" "" "" "");sets style for well material label
  874. (command "line" ul "@.105<180" "");draws tick at top of layer
  875. (setq try (- thick 0.05))
  876. (setq trx -0.15)
  877. (setq tstart(list trx try))
  878. ;**** (prompt "\nDepth to formation:")
  879. ;**** (setq fdepth(read-line))
  880. (setq runda (- totald a))
  881. (setq text(rtos runda 2 1))
  882. (command "text" "j" "r" tstart "0" text) ;adds depth label
  883. (setq lry(- try 0.11))
  884. (setq lstart(list trx lry))
  885. (prompt "\nLabel for formation: ")
  886. (prompt "\nMaximum of 14 characters  ")
  887. (setq flabel(read-line))
  888. (command "text" "j" "r" lstart "0" flabel) ;adds formation label
  889. (setq fans(getstring "\nAnother line of text? (Y or N) "))
  890.      (while (or(= fans "y") (= fans "Y"));while loop
  891.      (prompt "\nNext label for formation: ")
  892.      (prompt "\nMaximum of 14 characters  ")
  893.      (setq flabel(read-line))
  894.      (setq lry(- lry 0.11))
  895.      (setq lstart(list trx lry))
  896.      (command "text" "j" "r" lstart "0" flabel) ;adds formation label
  897.      (setq fans(getstring "\nAnother line of text? (Y or N) "))
  898.      );ends while loop
  899. ;
  900. (setq ydis thick)
  901. ;(setq answer "y")
  902.       (setq answer (getstring "\nAnother Layer? (Y or N)"))
  903.       (while (or (= answer "y") (= answer "Y"))    ;while loop
  904.       (setq a(getreal "\nThickness of layer: ")) 
  905.       ;(setq testcond runda)
  906.       ;(setq runda (- runda a))
  907.       (setq temp(/ a scale))
  908.       (setq thick (+ temp ydis))
  909.       (setq eight 8)
  910.            (if (> thick eight)
  911.              (progn
  912.                    (prompt "\nTHICKNESS EXCEEDS GROUND SURFACE!!")
  913.                (prompt "\n AutoLog can Perform rounding to top of surface")
  914.      (setq answer (getstring "\nTry Again or Autoround? (T or A): "))
  915.       (if (or (= answer "t") (= answer "T"))
  916.               (progn
  917.                    (setq answer "y")
  918.                   ; (setq runda testcond)
  919.               );closes progn
  920.               (progn
  921.                    (setq thick 8)
  922.                 (setq ll(list x ydis))
  923.                 (setq ul(list x thick))
  924.                 (setq ur(list xr thick)) 
  925.                 (setq lr(list xr ydis))
  926.                 (command "pline" ll ul ur lr "c")
  927.                 (setq ydis (+ ydis temp))
  928.                 (hatch)
  929.                 (command "pline" ul ur "")
  930.                 (command "pedit" (entlast) "w" ".01" "")
  931.                 (command "line" ul "@.105<180" "");draws tick at top of layer
  932.                 (setq try (- thick 0.05))
  933.                 (setq trx -0.15)
  934.                 (setq tstart(list trx try))
  935.                 ;(prompt "\nDepth to formation:")
  936.                 ;(setq fdepth(read-line))
  937.                ; (command "text" "j" "r" tstart "0" fdepth) ;adds depth label
  938.                 (setq lry(- try 0.11))
  939.                 (setq lstart(list trx lry))
  940.                 (prompt "\nLabel for formation: ")
  941.                 (prompt "\nMaximum of 14 characters  ")
  942.                 (setq flabel(read-line))
  943.                 (command "text" "j" "r" lstart "0" flabel) ;adds formation label
  944.                 (setq fans(getstring "\nAnother line of text? (Y or N) "))
  945.                      (while (or(= fans "y") (= fans "Y"));while loop
  946.                      (prompt "\nNext label for formation: ")
  947.                      (prompt "\nMaximum of 14 characters  ")
  948.                      (setq flabel(read-line))
  949.                      (setq lry(- lry 0.11))
  950.                      (setq lstart(list trx lry))
  951.                      (command "text" "j" "r" lstart "0" flabel) ;adds formation label
  952.                      (setq fans(getstring "\nAnother line of text? (Y or N) "))
  953.                      );ends while loop
  954.                 );closes progn
  955.                );closes if
  956.              );ends progn
  957.              (progn
  958.                 (setq ll(list x ydis))
  959.                 (setq ul(list x thick))
  960.                 (setq ur(list xr thick)) 
  961.                 (setq lr(list xr ydis))
  962.                 (command "pline" ll ul ur lr "c")
  963.                 (setq ydis (+ ydis temp))
  964.                 (hatch)
  965.                 (command "pline" ul ur "")
  966.                 (command "pedit" (entlast) "w" ".01" "")
  967.                 (command "line" ul "@.105<180" "");draws tick at top of layer
  968.                 (setq try (- thick 0.05))
  969.                 (setq trx -0.15)
  970.                 (setq tstart(list trx try))
  971.                 ;(prompt "\nDepth to formation:")
  972.                 ;(setq fdepth(read-line))
  973.                 (setq runda (- runda a))
  974.                 (setq text(rtos runda 2 1))
  975.                 (command "text" "j" "r" tstart "0" text) ;adds depth label
  976.                 (setq lry(- try 0.11))
  977.                 (setq lstart(list trx lry))
  978.                 (prompt "\nLabel for formation: ")
  979.                 (prompt "\nMaximum of 14 characters  ")
  980.                 (setq flabel(read-line))
  981.                 (command "text" "j" "r" lstart "0" flabel) ;adds formation label
  982.                 (setq fans(getstring "\nAnother line of text? (Y or N) "))
  983.                      (while (or(= fans "y") (= fans "Y")) ;while loop
  984.                      (prompt "\nNext label for formation: ")
  985.                      (prompt "\nMaximum of 14 characters  ")
  986.                      (setq flabel(read-line))
  987.                      (setq lry(- lry 0.11))
  988.                      (setq lstart(list trx lry))
  989.                      (command "text" "j" "r" lstart "0" flabel) ;adds formation label
  990.                      (setq fans(getstring "\nAnother line of text? (Y or N) "))
  991.                      );ends while loop
  992.                 (setq answer (getstring "\nAnother Layer? (Y or N)"))
  993.             );ends progn
  994.          );ends if
  995.       );ends while loop
  996. ;(command "move" "w" "-3,-3" "20,20" "" "1.5,3.99" "1.89,4.95")
  997. ;(command "move" "w" "-3,-3" "20,20" "" ".3878,.95" "1.65,.5")
  998. ; (command "pline" "0,0" "0,11" "8.5,11" "8.5,0" "0,0" "");draws box
  999. ; (command "pedit" (entlast) "w" ".02" "")
  1000. ;
  1001. (command "insert" "header" "-1,10" "" "" "")
  1002. ;  ****  END OF PROGRAM  ****   !!!HURRAY!!!
  1003. );ends program
  1004.