Author Topic: The Cutting Stock Problem (Optimizing Cutting of Rebar or Other Material)  (Read 17436 times)

0 Members and 1 Guest are viewing this topic.

ymg

  • Guest
Bear with me, this post is a bit long.

Here's an implementation of the 1D Cutting Stock Problem as per a method proposed
in the following paper:

  A GENERALIZED APPROACH TO THE SOLUTION OF ONE-DIMENSIONAL STOCK-CUTTING PROBLEM FOR SMALL SHIPYARDS

For a bit of background, CAB, in a previous post proposed a method where he develops the list of Lengths
and the list of Demand into a long list, where the Lengths are repeated as specified by the Demand list.

He then proceed to binpack the developed list into bins of size equal to the standard stock length.

T.Willey in another post seems to have essentially the same strategy in his CutPipes function.

For the Generalized Approach we order the list of Lengths in decreasing order and make the associated list of Demand follows.

The Feasible Cutting Patterns for the First Length with a Demand greater than Zero are then generated.

The resulting List of Patterns is then expanded to includes so that each pattern is associated with:
                Trim Loss tl,   Stock Material sm (Nb of times we apply this pattern without exceeding  any of Demand.)
                and finally  Parts Used pu (How many parts are being cut.)

This expanded list is sorted with the following criteria:
                Minimum Trim Loss, Maximum Stock Material and Minimum Parts Used.

The best pattern to used now sits at the top of our patterns list, and is used to adjust the List of Demand.

The process loop back to Generate the Feasible Cutting Pattern until all Demand are satisfied.

As a side note, I have intentionally kept the function "genpat" separated so it can be used to generates all feasible patterns
or only the subset of pattern for  a given demanded length.   The "genpat" function was coded as per Appendix I of
the following paper:
        Cutting Stock Waste Reduction Using Genetic Algorithms  by  Y. Khalifa, O. Salem and A. Shahin

Here is the code:     
Code - Auto/Visual Lisp: [Select]
  1. ;; 1d-csp       by ymg                                                        ;
  2. ;;                                                                            ;
  3. ;; Cutting Stock Problem as per approach described in:                        ;
  4. ;;                                                                            ;
  5. ;;               A GENERALIZED APPROACH TO THE SOLUTION                       ;
  6. ;;                  OF ONE-DIMENSIONAL STOCK-CUTTING                          ;
  7. ;;                    PROBLEM FOR SMALL SHIPYARDS.                            ;
  8. ;;              by Ahmet Cemil Dikili and Baris Barlas                        ;
  9. ;;                                                                            ;
  10. ;; Link:  http://jmst.ntou.edu.tw/marine/19-4/368-376.pdf                     ;
  11. ;;                                                                            ;
  12. ;; Argument: l   List, Demanded Lengths                                       ;
  13. ;;           d   List, Number of Corresponding Demanded Length.               ;
  14. ;;          ls   Real, Length of Standard Stock.                              ;
  15. ;;                                                                            ;
  16. ;; Returns: A List of Cutting Patterns, where each member is composed         ;
  17. ;;          of 3 items as follow: Item 1, Nb of times to apply Pattern.       ;
  18. ;;                                Item 2, List of integers where each         ;
  19. ;;                                        element correspond to the nb of     ;
  20. ;;                                        times to use a demanded length.     ;
  21. ;;                                Item 3, Total Waste for this Pattern.       ;
  22. ;;                                                                            ;
  23.  
  24. (defun 1D-CSP (l d ls / a ch cp idx maxint p tl sm pu v)
  25.    (setq maxint 2147483647
  26.             idx (vl-sort-i l '>)
  27.               l (mapcar '(lambda (x) (nth x l)) idx)
  28.               d (mapcar '(lambda (x) (nth x d)) idx)         
  29.    )
  30.    (while  (> (apply '+ d) 0)
  31.       (setq v (genpat l d ls nil) p nil)      
  32.       (foreach a v
  33.          (setq tl (- ls (apply '+ (mapcar '(lambda (a l) (* a l)) a l)))
  34.                sm (apply 'min (mapcar '(lambda (a d) (if (> a 0) (/ d a) maxint)) a d))
  35.                pu (* sm (apply '+ a))
  36.                 p (cons (list a tl sm pu) p)
  37.          )
  38.       )
  39.      
  40.       ; Here we Sort the Set of Patterns on Min tl, Max sm and Min pu         ;
  41.       ; The Chosen Pattern will bubble up to top of the list.                 ;
  42.      
  43.       (setq p (vl-sort (reverse p) '(lambda (a b) (if (= (cadr a) (cadr b))
  44.                                            (if (= (caddr a) (caddr b))
  45.                                               (< (cadddr a) (cadddr b))  
  46.                                               (> (caddr a) (caddr b))
  47.                                            )     
  48.                                            (< (cadr  a) (cadr  b))
  49.                                         )
  50.                           )
  51.               )
  52.       )
  53.      
  54.       ; Building the Cutting Plan, then Adjusting the Demand List.            ;
  55.      
  56.       (setq ch (car p))
  57.       (setq cp (cons (list (caddr ch) (car ch) (* (cadr ch) (caddr ch))) cp))
  58.       (setq  d (mapcar '(lambda (d p) (- d (* p (caddr ch)))) d (car ch)))      
  59.    )
  60.    (reverse cp)
  61. )
  62.  
  63.  
  64. ;; genpat                  by ymg                                             ;
  65. ;;                                                                            ;
  66. ;; Procedure for Generating the Efficient Feasible Cutting Patterns           ;
  67. ;; http://www.cs.bham.ac.uk/~wbl/biblio/gecco2006/docs/p1675.pdf              ;
  68. ;; Appendix 1                                                                 ;
  69. ;; Part of "Cutting Stock Waste Reduction Using Genetic Algorithms"           ;
  70. ;;              by Y. Khalifa, O. Salem and A. Shahin                         ;
  71. ;;                                                                            ;
  72. ;; Argument: l   List, Demanded Lengths in Descending Order.                  ;
  73. ;;           d   List, Number of Corresponding Demanded Length.               ;
  74. ;;          ls   Real, Length of Standard Bar.                                ;
  75. ;;         all   Boolean, if true, Generate all Feasible Patterns.            ;
  76. ;;                        if false, Generates only the Set of Patterns        ;
  77. ;;                                  for the First Demand > 0                  ;
  78. ;;                                                                            ;
  79.  
  80. (defun genpat (l d ls all / a i j p  s)
  81.    (setq i 0) (while (zerop (nth i d)) (setq i (1+ i)))
  82.    (if (= (1+ i) (length d)) (setq all t))
  83.    (while (or (not a) (if all (> (apply '+ (cdr a)) 0) (> (nth i (reverse a)) 0)))
  84.       (cond
  85.           (a (setq a (cdr a))
  86.              (while (zerop (car a)) (setq a (cdr a)))
  87.              (setq a (cons (1- (car a)) (cdr a))
  88.                    j (length a)
  89.                    s (apply '+ (mapcar '(lambda (a l) (* a l)) (reverse a) l))
  90.              )
  91.            )
  92.            (t (setq j 0 s 0))
  93.       )  
  94.       (while (< j (length l))
  95.          (setq a (cons (min (floor (/ (- ls s) (nth j l))) (nth j d)) a)
  96.                s (+ s (* (car a) (nth j l)))
  97.                j (1+ j)
  98.          )
  99.       )
  100.       (setq p (cons (reverse a) p))
  101.    )  
  102.    (if all (reverse p) (reverse (cdr p)))
  103. )
  104.  
  105. ;; Ceiling function, Returns the smallest integer not less than x.            ;
  106. (defun ceil  (x) (if (> (rem x 1) 0) (+ (fix x) 1) (fix x)))
  107. ;; Floor function, Returns the largest integer not greater than x.            ;
  108. (defun floor (x) (if (minusp (rem x 1)) (- (fix x) 1) (fix x)))
  109.  
  110.  
  111. (defun c:test (/ l1 l2 d1 d2 ls1 ls2)
  112.    (defun prinlst (p l / i idx)
  113.      (setq idx (vl-sort-i l '>)
  114.              l (mapcar '(lambda (x) (nth x l)) idx)
  115.      )
  116.      (princ (strcat "\nL: " (vl-princ-to-string l)))
  117.      (foreach i p (princ (strcat "\n" (vl-princ-to-string i))))
  118.      (princ "\n")
  119.      (princ (strcat "\n   Nb of Stock used: " (itoa (apply '+ (mapcar 'car p)))))
  120.      (princ (strcat "\n Nb of Parts Cutted: " (itoa (apply '+ (mapcar '(lambda (a) (* (car a) (apply '+ (cadr a)))) p)))))
  121.      (princ (strcat "\nTotal Length Wasted: " (rtos (apply '+ (mapcar 'caddr p)) 2 2)))
  122.      (princ "\n\n\n")      
  123.    )
  124.    ;; Problem 1                              ;
  125.    (setq l1 '(60.0 50.0 30.0 25.0 20.0 10.0)
  126.          d1 '(6 7 15 20 9 16)
  127.         ls1 100.0
  128.    )
  129.    ;; Problem 2                              ;
  130.    (setq l2 '(40.0 30.0 20.0 10.0 5.0)
  131.          d2 '(7 10 6 4 2)
  132.         ls2 100.0
  133.    )
  134.    ;; Problem 3 by Cab                       ;
  135.    (setq l3 '(7.65 5.30 3.67 2.66 9.71 4.00)
  136.          d3 '(23 10 54 67 44 120)
  137.          ls3 12.01
  138.    )
  139.    ;; Problem 4  by Jeff H.                  ;
  140.    (setq l4 '(15.3 14.4 12.34)
  141.          d4 '(4 30 2)
  142.          ls4  60.0
  143.    )
  144.    ;; Problem 5  by ElpanovEvgenyi          ;
  145.    (setq l5 '(62 20  9 8 12 17 6)
  146.          d5 '(1 1 2 1 1 1 1 1)
  147.          ls5 80
  148.    )
  149.    (textscr)
  150.    (prinlst (1d-csp l1 d1 ls1) l1)
  151.    (prinlst (1d-csp l2 d2 ls2) l2)
  152.    (prinlst (1d-csp l3 d3 ls3) l3)  
  153.    (prinlst (1d-csp l4 d4 ls4) l4)
  154.    (prinlst (1d-csp l5 d5 ls5) l5)
  155.    (princ)  
  156. )
  157.  

ymg
« Last Edit: February 18, 2015, 03:29:11 PM by ymg »

serge_c

  • Newt
  • Posts: 39
Re: The Cutting Stock Problem (Optimizing Cutting of Rebar or Other Material)
« Reply #1 on: February 18, 2015, 09:06:05 AM »
Hi ymg !!!
Sorry but I can't undestand how it works ?
I saw a lisp file, I put it in mine attached file , I can not understand the meaning of the results?

ymg

  • Guest
Re: The Cutting Stock Problem (Optimizing Cutting of Rebar or Other Material)
« Reply #2 on: February 18, 2015, 09:38:56 AM »
sergiu,

For example in problem 3, the lengths in decreasing order are:

      (9.71 7.65 5.3 4.0 3.67 2.66)

And the result for this problem is:

(44 (1 0 0 0 0 0) 101.2)
(23 (0 1 0 1 0 0) 8.28)
(10 (0 0 1 1 0 1) 0.5)
(29 (0 0 0 3 0 0) 0.29)
(19 (0 0 0 0 1 3) 6.84)
(11 (0 0 0 0 3 0) 11.0)
(1 (0 0 0 0 2 0) 4.67)

   Nb of Stock used: 137
 Nb of Parts Cutted: 318
Total Length Wasted: 132.78

So it means:

Cut 44 bars with only Length 9.71, loss is 101.2
Cut 23 bars with length 7.65 and 4.00, loss is 8.28
Cut 10 bars,  lengths 5.3, 4.00 and 2.66, loss is 0.5
Cut 29 bars,  lengths 4.00, 4.00, 4.00, loss is 0.29
 and so on.

Each result is a list of sublist.
Each sublist contains 3 items:

Item1 : How many times you cut the pattern
Item2 : Is a list of integers, meaning how many times a length is cut.
Item3 : Is a number representing the total loss generated by applying this pattern.

ymg

« Last Edit: February 18, 2015, 09:50:32 AM by ymg »

serge_c

  • Newt
  • Posts: 39
Re: The Cutting Stock Problem (Optimizing Cutting of Rebar or Other Material)
« Reply #3 on: February 20, 2015, 10:23:18 AM »
Ymg , the third problem is what a need ,I understood it , I change some values manualy and it work realy fine, now the big problem is how to introduce them automaticaly in lisp file,it gona take a long way to do it manualy , first I need to export and sort them in excell after that to copy them to lisp file .
One more iDea it will be cool if every problem will reprezent a diameter for example: Problem 1 :∅10; Problem 2 :∅12; Problem 3 :∅14;... ∅16;∅18;∅20;∅22;∅25;
∅28; Problem 10 :∅32;

ymg

  • Guest
Re: The Cutting Stock Problem (Optimizing Cutting of Rebar or Other Material)
« Reply #4 on: February 20, 2015, 05:50:54 PM »
sergiu,

Here I've modified the lisp so it will read
your file if you save it as csv.

Don't want to mess with direct from excel
as there are too many versions.

The Output is still crude and to the text screen.

To Run issue the command "SERGIU"

Code - Auto/Visual Lisp: [Select]
  1. ;; 1d-csp       by ymg                                                        ;
  2. ;;                                                                            ;
  3. ;; Cutting Stock Problem as per approach described in:                        ;
  4. ;;                                                                            ;
  5. ;;               A GENERALIZED APPROACH TO THE SOLUTION                       ;
  6. ;;                  OF ONE-DIMENSIONAL STOCK-CUTTING                          ;
  7. ;;                    PROBLEM FOR SMALL SHIPYARDS.                            ;
  8. ;;              by Ahmet Cemil Dikili and Baris Barlas                        ;
  9. ;;                                                                            ;
  10. ;; Link:  http://jmst.ntou.edu.tw/marine/19-4/368-376.pdf                     ;
  11. ;;                                                                            ;
  12. ;; Argument: l   List, Demanded Lengths in Decreasing order.                  ;
  13. ;;           d   List, Number of Corresponding Demanded Length.               ;
  14. ;;          ls   Real, Length of Standard Stock.                              ;
  15. ;;                                                                            ;
  16. ;; Returns: A List of Cutting Patterns, where each member is composed         ;
  17. ;;          of 3 items as follow: Item 1, Nb of times to apply Pattern.       ;
  18. ;;                                Item 2, List of integers where each         ;
  19. ;;                                        element correspond to the nb of     ;
  20. ;;                                        times to use a demanded length.     ;
  21. ;;                                Item 3, Total Waste for this Pattern.       ;
  22. ;;                                                                            ;
  23.  
  24. (defun 1D-CSP (l d ls / a ch cp idx maxint p tl sm pu v)
  25.    (setq maxint 2147483647)
  26.            
  27.    (while  (> (apply '+ d) 0)
  28.       (setq v (genpat l d ls nil) p nil)      
  29.       (foreach a v
  30.          (setq tl (- ls (apply '+ (mapcar '(lambda (a l) (* a l)) a l)))
  31.                sm (apply 'min (mapcar '(lambda (a d) (if (> a 0) (/ d a) maxint)) a d))
  32.                pu (* sm (apply '+ a))
  33.                 p (cons (list a tl sm pu) p)
  34.          )
  35.       )
  36.      
  37.       ; Here we Sort the Set of Patterns on Min tl, Max sm and Min pu         ;
  38.       ; The Chosen Pattern will bubble up to top of the list.                 ;
  39.      
  40.       (setq p (vl-sort p '(lambda (a b) (if (= (cadr a) (cadr b))
  41.                                            (if (= (caddr a) (caddr b))
  42.                                               (< (cadddr a) (cadddr b))  
  43.                                               (> (caddr a) (caddr b))
  44.                                            )     
  45.                                            (< (cadr  a) (cadr  b))
  46.                                         )
  47.                           )
  48.               )
  49.       )
  50.      
  51.       ; Building the Cutting Plan, then Adjusting the Demand List.            ;
  52.      
  53.       (setq ch (car p))
  54.       (setq cp (cons (list (caddr ch) (car ch) (* (cadr ch) (caddr ch))) cp))
  55.       (setq  d (mapcar '(lambda (d p) (- d (* p (caddr ch)))) d (car ch)))      
  56.    )
  57.    (reverse cp)
  58. )
  59.  
  60.  
  61. ;; genpat                  by ymg                                             ;
  62. ;;                                                                            ;
  63. ;; Procedure for Generating the Efficient Feasible Cutting Patterns           ;
  64. ;; http://www.cs.bham.ac.uk/~wbl/biblio/gecco2006/docs/p1675.pdf              ;
  65. ;; Appendix 1                                                                 ;
  66. ;; Part of "Cutting Stock Waste Reduction Using Genetic Algorithms"           ;
  67. ;;              by Y. Khalifa, O. Salem and A. Shahin                         ;
  68. ;;                                                                            ;
  69. ;; Argument: l   List, Demanded Lengths in Descending Order.                  ;
  70. ;;           d   List, Number of Corresponding Demanded Length.               ;
  71. ;;          ls   Real, Length of Standard Bar.                                ;
  72. ;;         all   Boolean, if true, Generate all Feasible Patterns.            ;
  73. ;;                        if false, Generates only the Set of Patterns        ;
  74. ;;                                  for the First Demand > 0                  ;
  75. ;;                                                                            ;
  76.  
  77. (defun genpat (l d ls all / a i j p  s)
  78.    (setq i 0) (while (zerop (nth i d)) (setq i (1+ i)))
  79.    (if (= (1+ i) (length d)) (setq all t))
  80.    (while (or (not a) (if all (> (apply '+ (cdr a)) 0) (> (nth i (reverse a)) 0)))
  81.       (cond
  82.           (a (setq a (cdr a))
  83.              (while (zerop (car a)) (setq a (cdr a)))
  84.              (setq a (cons (1- (car a)) (cdr a))
  85.                    j (length a)
  86.                    s (apply '+ (mapcar '(lambda (a l) (* a l)) (reverse a) l))
  87.              )
  88.            )
  89.            (t (setq j 0 s 0))
  90.       )  
  91.       (while (< j (length l))
  92.          (setq a (cons (min (floor (/ (- ls s) (nth j l))) (nth j d)) a)
  93.                s (+ s (* (car a) (nth j l)))
  94.                j (1+ j)
  95.          )
  96.       )
  97.       (setq p (cons (reverse a) p))
  98.    )  
  99.    (if all (reverse p) (reverse (cdr p)))
  100. )
  101.  
  102. ;; Ceiling function, Returns the smallest integer not less than x.            ;
  103. (defun ceil  (x) (if (> (rem x 1) 0) (+ (fix x) 1) (fix x)))
  104. ;; Floor function, Returns the largest integer not greater than x.            ;
  105. (defun floor (x) (if (minusp (rem x 1)) (- (fix x) 1) (fix x)))
  106.  
  107.  
  108. (defun c:test (/ l1 l2 d1 d2 ls1 ls2)
  109.    (setq prob '(("Problem 1  by Dikili & Barlas          \n"
  110.                   (60.0 50.0 30.0 25.0 20.0 10.0)
  111.                   (6 7 15 20 9 16)
  112.                   100.0
  113.                 )
  114.                 ("Problem 2  by Dikili & Barlas          \n"
  115.                   (40.0 30.0 20.0 10.0 5.0)
  116.                   (7 10 6 4 2)
  117.                   100.0
  118.                 )
  119.                 ("Problem 3 by CAB                       \n"        
  120.                   (9.71 7.65 5.30 4.00 3.67 2.66)
  121.                   (44 23 10 54 120 67)
  122.                   12.01
  123.                 )
  124.                 ("Problem 4  by Jeff H.                  \n"
  125.                   (15.3 14.4 12.34)
  126.                   (4 30 2)
  127.                    60.0
  128.                 )
  129.                 ("Problem 5  by ElpanovEvgenyi           \n"  
  130.                  (62 20 17 12 9 8 6)
  131.                  (1 1 1 1 1 2 1 1)
  132.                  80
  133.                 )
  134.                 ("Problem 6  by Khalifa, Salem & Shahin  \n"
  135.                   (19.0 15.5 15 12 10 8.5)
  136.                   (4 4 4 4 4 4 4)
  137.                   40.00
  138.                 )
  139.                 ("Problem 7  by Khalifa, Salem & Shahin  \n"
  140.                   (12.146 11.896 11.729 9.396 9.0625 7.229 4.177 3.0)
  141.                   (2 2 32 6 4 4 28 6)
  142.                   40.00
  143.                 )
  144.                 ("Problem 8  by sergiu                   \n"
  145.                   (4.500 3.600 3.100 1.400 0.750)
  146.                   (97 610 395 211 300)
  147.                   12.000
  148.                 )
  149.                )
  150.    )
  151.    (foreach pr prob
  152.       (solve pr)
  153.    )  
  154.    (princ)  
  155. )
  156.  
  157. ;; solve       by ymg                                                         ;
  158. ;;                                                                            ;
  159. ;; A temporary, somewhat crude Output for testing purposes.                   ;
  160. ;; Could be replaced by an Acad table or an Output to Excel                   ;
  161. ;;                                                                            ;
  162. ;; Argument:                                                                  ;
  163. ;;           pr, List of 4 items (title l d ls)                               ;
  164. ;;              Where title,  is a String                                     ;
  165. ;;                        l,  List of Demanded Lengths in Decreasing Order    ;
  166. ;;                        d,  List of Associated Demand                       ;
  167. ;;                       ls,  Length of a Standard Bar.                       ;
  168. ;;                                                                            ;
  169. ;; The routine calls "1D-CSP"                                                 ;
  170. ;;                                                                            ;
  171.  
  172. (defun solve (pr / p tit l d ls i)
  173.    (textscr)
  174.    (setq tit (car   pr)
  175.            l (cadr  pr)
  176.            d (caddr pr)
  177.           ls (last  pr)
  178.            p (1d-csp l d ls)
  179.    )
  180.    (princ tit)
  181.    (princ (strcat "\nD: " (vl-princ-to-string d)))
  182.    (princ (strcat "\nL: " (vl-princ-to-string l)))
  183.    (foreach i p (princ (strcat "\n" (vl-princ-to-string i))))
  184.    (princ "\n")
  185.    (princ (strcat "\n   Nb of Stock used: " (itoa (apply '+ (mapcar 'car p)))))
  186.    (princ (strcat "\n Nb of Parts Cutted: " (itoa (apply '+ (mapcar '(lambda (a) (* (car a) (apply '+ (cadr a)))) p)))))
  187.    (princ (strcat "\nTotal Length Wasted: " (rtos (apply '+ (mapcar 'caddr p)) 2 2)))
  188.    (princ "\n\n\n")        
  189. )
  190.  
  191. ;; ReadCSV  -  Lee Mac                                                        ;
  192. ;; Parses a CSV file into a list of lists,                                    ;
  193. ;;              each sublist is a row of CSV cell values.                     ;
  194. ;;                                                                            ;
  195.  
  196. (defun ReadCSV ( filename / _csv->lst file line lst )
  197.  
  198.     (defun _csv->lst ( str / pos )
  199.         (if (setq pos (vl-string-position 44 str))
  200.             (cons (substr str 1 pos) (_csv->lst (substr str (+ pos 2))))
  201.             (list str)
  202.         )
  203.     )
  204.  
  205.     (if (setq file (open (findfile filename) "r"))
  206.         (progn
  207.             (while (setq line (read-line file))
  208.                 (setq lst (cons (_csv->lst line) lst))
  209.             )
  210.             (close file)
  211.         )
  212.     )
  213.     (reverse lst)
  214. )
  215.  
  216. ;; massoc       by Gile Chanteau                                              ;
  217. ;;                                                                            ;
  218. ;; Returns a list of all items associated with the specified key              ;
  219. ;; in an association list.                                                    ;
  220. ;;                                                                            ;
  221. ;; Arguments:                                                                 ;
  222. ;;    k,  The value to search for in the list.                                ;
  223. ;;    l,  List of Associations                                                ;
  224. ;;                                                                            ;
  225.  
  226. (defun massoc (k l)
  227.   (if (setq l (member (assoc k l) l))
  228.     (cons (cdar l) (massoc k (cdr l)))
  229.   )
  230. )
  231.  
  232. ;; distinct     by Gile Chanteau                                              ;
  233. ;; Deletes all duplicates in a list.                                          ;
  234. ;;                                                                            ;
  235. ;; Argument                                                                   ;
  236. ;; l   List                                                                   ;
  237. ;;                                                                            ;
  238. (defun distinct (l)
  239.   (if l
  240.     (cons (car l) (distinct (vl-remove (car l) l)))
  241.   )
  242. )
  243.  
  244.  
  245. (defun c:sergiu (/ a d data fn l ld ls size title)
  246.    (setq ls 12000)                            ; Length of Standard Bar                ;
  247.    (prompt "Select CSV File Containing Your Data :")
  248.    (setq fn (getfiled "Import CSV File" "" "csv" 8))
  249.          
  250.    (setq data (cdr (ReadCSV fn))              ; cdr is to discard the line of titles  ;
  251.          size (distinct (mapcar 'cadr data))  ; size is the list of distinct diameters;
  252.          data (mapcar '(lambda (a) (list (cadr a) (atoi (caddr a)) (atoi (last a)))) data)
  253.    )
  254.    ;; Data is now an association list and length and demand are in Integers.          ;
  255.    (foreach diam size
  256.       (setq title (strcat "Cutting Patterns for Diam. " diam)
  257.               ld  (vl-sort (massoc diam data) '(lambda (a b) (> (car a) (car b))))
  258.                l  (mapcar 'car  ld)
  259.                d  (mapcar 'cadr ld)        
  260.       )
  261.       (solve (list title l d ls))
  262.    )
  263.    (princ)
  264. )  
  265.  

ymg
« Last Edit: February 21, 2015, 06:13:54 AM by ymg »

serge_c

  • Newt
  • Posts: 39
Re: The Cutting Stock Problem (Optimizing Cutting of Rebar or Other Material)
« Reply #5 on: February 21, 2015, 02:42:08 AM »
Command " sergiu " : funny !!!
"The Output is still crude , in to the text screen" That's right , it gonna be more useful in table format, but is enough for you , you really work to much !!!
Phanks a lot , you help the economy of Moldova and not only Moldova I think !!!  :-)

ymg

  • Guest
Re: The Cutting Stock Problem (Optimizing Cutting of Rebar or Other Material)
« Reply #6 on: February 21, 2015, 05:09:22 AM »
sergiu,

Long live Moldova!!

Modified the SERGIU command, as we do not really
need to build the prob list.

So a litlle more concise here:

Code - Auto/Visual Lisp: [Select]
  1. (defun c:sergiu (/ a d data fn l ld ls size title)
  2.    (setq ls 12000)                            ; Length of Standard Bar                ;
  3.    (prompt "Select CSV File Containing Your Data :")
  4.    (setq fn (getfiled "Import CSV File" "" "csv" 8))
  5.          
  6.    (setq data (cdr (ReadCSV fn))              ; cdr is to discard the line of titles  ;
  7.          size (distinct (mapcar 'cadr data))  ; size is the list of distinct diameters;
  8.          data (mapcar '(lambda (a) (list (cadr a) (atoi (caddr a)) (atoi (last a)))) data)
  9.    )
  10.    ;; Data is now an association list and length and demand are in Integers.          ;
  11.    (foreach diam size
  12.       (setq title (strcat "Cutting Patterns for Diam. " diam)
  13.               ld  (vl-sort (massoc diam data) '(lambda (a b) (> (car a) (car b))))
  14.                l  (mapcar 'car  ld)
  15.                d  (mapcar 'cadr ld)        
  16.       )
  17.       (solve (list title l d ls))
  18.    )
  19.    (princ)
  20. )  
  21.  

Also in the 1d-csp routine we no longer need to sort the input list l and d
since we are doing it in the main calling routine.

ymg
« Last Edit: February 21, 2015, 05:49:13 AM by ymg »

ymg

  • Guest
Re: The Cutting Stock Problem (Optimizing Cutting of Rebar or Other Material)
« Reply #7 on: February 26, 2015, 09:02:34 AM »
I've analyzed the method of Dikili and Barlas proposed here.

There is Good news and Bad news.

On the bad side:

Because of the sequential nature of the solution the method
sometimes fail to identify solutions with less patterns.

Also, when the problem does not have a good dispersion of
length, the propose solution sometimes deteriorates to worse
than a simple First Fit Decreasing binpack.

On the good side:

It potentially finds solution better than simple binpack.

Below are two examples solutions by the two methods.
A third solution from a commercial program is also offered.
All solutions are list where: item 1   Nb of times to apply a pattern
                                           item 2   List of length composing the pattern
                                           item 3   Waste generated by pattern

Quote
Problem 1   D: (44 23 10 54 120 67)
                   L: (9.71 7.65 5.3 4.0 3.67 2.66)
                 Ls: 12.000

Dikili & Barlas
(44 (9.71) 2.29)
(23 (7.65 4.0) 0.35)
(10 (5.3 4.0 2.66) 0.04)
(7 (4.0 4.0 4.0) 0.0)
(19 (3.67 2.66 2.66 2.66) 0.35)                   
(33 (3.67 3.67 3.67) 0.99)
(1 (3.67 3.67) 4.66)


Nb of Stock used      : 137
Nb of Parts Cut         : 318
Total Length Wasted : 153.19
Percent Efficiency      : 90.6819 %
FFD-binpack
(44 (9.71) 2.29)
(23 (7.65 4.00) 0.35)
(5  (5.30 5.30) 1.40)
(10 (4.0 4.0 4.0) 0.00)
(1  (3.67 4.0 3.67) 0.66)
(39 (3.67 3.67 3.67) 0.99)
(1  (2.66 3.67 2.66 2.66) 0.35)
(16 (2.66 2.66 2.66 2.66) 1.36)           

Nb of Stock used      : 139
Nb of Parts Cut         : 318
Total Length Wasted : 177.19
Percent Efficiency      : 89.3771 %
A better solution from a commercial program.
(19 (4.00 2.66 2.66 2.66) 0.02)
(10 (5.30 4.00 2.66) 0.04)
(23 (7.65 4.00) 0.35)
(40 (3.67 3.67 3.67) 0.99)
(44 (9.71) 2.29)
(1  (4.00 4.00) 4.00)



Nb of Stock used      : 137
Nb of Parts Cut         : 318
Total Length Wasted : 153.19
Percent Efficiency      : 90.6819 %



Problem 2   D: (97 610 395 211 300)
                   L: (4.5 3.6 3.1 1.4 0.75)
                 Ls: 12.000


Dikili & Barlas
(75 (4.5 3.1 1.4 0.75 0.75 0.75 0.75)  0.0) 
(11 (4.5 4.5 1.4 1.4) 0.2)
(19 (3.6 1.4 1.4 1.4 1.4 1.4 1.4)  0.0)
(197 (3.6 3.6 3.6)  1.2)
(106 (3.1 3.1 3.1)  2.7)
(1 (3.1 3.1)  5.8 )



Nb of Stock used       : 409
Nb of Parts Cut          : 1613
Total Length Wasted : 530.60
Percent Efficiency      : 89.1891 %




FFD-binpack
(48  (1.4 4.5 4.5 1.4) 0.2)
(1   (3.6 4.5 3.6) 0.3)
(202 (3.6 3.6 3.6 0.75) 0.45)
(1   (3.1 3.6 3.6 1.4) 0.3)
(98  (1.4 3.1 3.1 3.1 0.75) 0.55)
(16  (3.1 3.1 3.1 1.4) 1.3)
(17  (3.1 3.1 3.1) 2.7)
(1   (3.1) 8.9)

Nb of Stock used      : 384
Nb of Parts Cut         : 1613
Total Length Wasted : 230.60
Percent Efficiency      : 94.9957 %
A Better Solution from a Commercial Program.
(2   (3.6 1.4 1.4 1.4 1.4 1.4 1.4) 0.0)
(1   (3.1 1.4 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75) 0.0)
(1   (0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75) 0.0)
(197 (3.6 3.1 3.1 1.4 0.75) 0.05)
(97  (4.5 3.6 3.6) 0.3)
(72  (3.6 3.6 3.6 0.75) 0.45)
(1   (3.6 1.4 0.75 0.75 0.75 0.75 0.75) 3.25)


Nb of Stock used      : 371
Nb of Parts Cut         : 1613
Total Length Wasted : 74.60
Percent Efficiency      : 98.3243 %


You can see in the second problem that the solution has deteriorated
to below binpack.

So as a next step, we could explore Dikili by changing the order that
we apply the patterns.

Both method being fast, we could compare Dikili's solution to a binpack,
and output the best.

I do believe however that a better overall solution would be
offered by applying a Genetic Algorithm.

With a proper evaluation function, we could have more constraints
on the solution.

On top of that a GA would return a range of possible solutions
instead of a single one. 

However, this would be at the cost of a much longer run time.

ymg
« Last Edit: February 26, 2015, 10:12:03 AM by ymg »

ymg

  • Guest
Re: The Cutting Stock Problem (Optimizing Cutting of Rebar or Other Material)
« Reply #8 on: February 26, 2015, 12:40:38 PM »
Here's the routine to generate Cut Patterns
by First Fit Decreasing binpack.

Code - Auto/Visual Lisp: [Select]
  1. ;; binpack-cut               by ymg                                           ;
  2. ;;                                                                            ;
  3. ;;                                                                            ;
  4. ;;                                                                            ;
  5. ;; Will return a Patterns List for Cutting the Demanded Lengths               ;
  6. ;;                                                                            ;
  7.  
  8. (defun c:binpack-cut (/ prob pr tit l d ls bins i p )
  9.    (setq prob '(("Problem 1  by Dikili & Barlas          \n"
  10.                   (60.0 50.0 30.0 25.0 20.0 10.0)
  11.                   (6 7 15 20 9 16)
  12.                   100.0
  13.                 )
  14.                )
  15.    )
  16.    (foreach pr prob
  17.       (setq tit (car   pr)
  18.               l (cadr  pr)
  19.               d (caddr pr)
  20.              ls (float (last  pr))
  21.       )
  22.      
  23.       (setq bins (distinct# (ffd-binpack (longlst l d) ls)))
  24.       (foreach i bins
  25.          (setq p (cons (reverse (cons (- ls (apply '+ (car i))) i)) p))
  26.       )
  27.       (setq p (reverse p))
  28.       (textscr)
  29.       (princ tit)
  30.       (princ (strcat "\n D: " (vl-princ-to-string d)))
  31.       (princ (strcat "\n L: " (vl-princ-to-string l)))
  32.       (princ (strcat "\nLs: " (rtos ls 2 3)))
  33.       (princ "\n")
  34.       (foreach i p (princ (strcat "\n" (vl-princ-to-string i))))
  35.       (princ "\n")
  36.       (princ (strcat "\nNb of Stock used    : " (itoa (setq su (apply '+ (mapcar 'car p))))))
  37.       (princ (strcat "\nNb of Parts Cut     : " (itoa (apply '+ (mapcar '(lambda (a) (* (car a) (length (cadr a)))) p)))))
  38.       (princ (strcat "\nTotal Length Wasted : " (rtos (setq w (apply '+ (mapcar '(lambda (a) (* (car a) (caddr a))) p))) 2 2)))
  39.       (princ (strcat "\nNb Patterns used    : " (itoa (length p))))
  40.       (princ (strcat "\nPercent Efficiency  : " (rtos (* 100 ( / (- (* su ls) w) (* su ls))) 2 4) " %"))
  41.       (princ "\n\n\n")
  42.    )
  43.    (princ)
  44. )
  45.  
  46. ;; distinct#    by ymg  (Derived from Distinct by Gile Chanteau               ;
  47. ;; Returns a list of distinct Item and Quantity ((item qty)......)            ;
  48. ;; Argument                                                                   ;
  49. ;; l   List                                                                   ;
  50. ;;                                                                            ;
  51.  
  52. (defun distinct# (l)
  53.    (if l
  54.      (cons (list (car l) (- (length l) (length (setq l (vl-remove (car l) l))))) (distinct# l))    
  55.    )
  56. )
  57.  
  58.  
  59. ;; FFD-binpack         by ymg    (Simplified Gile Chanteau's solution.        ;
  60. ;; First Fit Decreasing                                                       ;
  61. ;; Arguments: l  List of items to put in bins                                 ;
  62. ;;            c  Capacity of a bin                                            ;
  63. ;;                                                                            ;
  64.  
  65. (defun FFD-binpack (l c / i b tmp)
  66.    (foreach  i (vl-sort-i l '>)
  67.        (setq i (nth i l)  tmp nil)
  68.        (cond     
  69.           (b (while (and (> i (- c (apply '+ (car b)))) b)
  70.                (setq tmp (cons (car b) tmp)  b (cdr b))
  71.              )  
  72.              (setq b (append (reverse (cons (reverse (cons i (car b))) tmp)) (cdr b)))               
  73.           )
  74.           (t (setq b (list (list i))))
  75.        )
  76.    )
  77. )
  78.  
  79. ; Expand a list of length and quantity into a long list with repeating items  ;
  80.  
  81. (defun longlst (l d / i j ll)
  82.   (setq j -1)
  83.   (foreach i d
  84.     (setq j (1+ j))
  85.     (repeat i (setq ll (cons (nth j l) ll)))
  86.   )
  87. )
  88.  

ymg

serge_c

  • Newt
  • Posts: 39
 Hi Ymg again !!!
Here is a real example that last method "Dikili and Barlas" gives better solutions that "problem 8": Command: BINPACK-CUT Problem 1  by Dikili & Barlas

 D: (6 32 158 42 45)
 L: (7500.0 6000.0 4500.0 4000.0 3000.0)
Ls: 12000

(6 (7500.0 4500.0) 0.0)
(16 (6000.0 6000.0) 0.0)
(45 (4500.0 4500.0 3000.0) 0.0)
(31 (4500.0 4500.0) 3000.0)
(14 (4000.0 4000.0 4000.0) 0.0)

Nb of Stock used    : 112
Nb of Parts Cut     : 283
Total Length Wasted : 93000
Nb Patterns used    : 5
Percent Efficiency  : 93.0804 %
//////////////////////////////////////////////////////////////////////////////////// Second one
Cutting Patterns for Diam. 28
D: (6 32 158 42 45)
L: (7500 6000 4500 4000 3000)
(6 (1 0 1 0 0) 0)
(22 (0 1 0 0 2) 0)
(5 (0 2 0 0 0) 0)
(1 (0 0 2 0 1) 0)
(75 (0 0 2 0 0) 225000)
(14 (0 0 0 3 0) 0)

   Nb of Stock used: 123
 Nb of Parts Cutted: 283
Total Length Wasted: 225000
« Last Edit: April 06, 2015, 09:46:06 AM by sergiu_ciuhnenco »

ymg

  • Guest
sergiu,

Thanks Sergiu, my only points was that in certain hard case
Dikili & Barlas sometimes returns a result worse than ffd-binpack.

So pending that I or somebody else comes up with something
better, it is wise to run both ffd-binpack and Dikili and keep
the best.

ymg

andy_lee

  • Newt
  • Posts: 147
Hello ymg.

Can you upload a demo gif ? thanks.
andy.
Best regards.

serge_c

  • Newt
  • Posts: 39
Ymg , I want to ask you for the last favor, If you can do the same thing  for Dikili & Barlas problems like you do it for previous problems ( what I mean , to not introducing manualy all numbers , but to make the proces a little bit faster) ..
Thanks in advance !!!

ymg

  • Guest
sergiu,

Here goes, it will now run both methods
for each diameters.

Code - Auto/Visual Lisp: [Select]
  1. ;; 1d-csp       by ymg                                                        ;
  2. ;;                                                                            ;
  3. ;; Cutting Stock Problem as per approach described in:                        ;
  4. ;;                                                                            ;
  5. ;;               A GENERALIZED APPROACH TO THE SOLUTION                       ;
  6. ;;                  OF ONE-DIMENSIONAL STOCK-CUTTING                          ;
  7. ;;                    PROBLEM FOR SMALL SHIPYARDS.                            ;
  8. ;;              by Ahmet Cemil Dikili and Baris Barlas                        ;
  9. ;;                                                                            ;
  10. ;; Link:  http://jmst.ntou.edu.tw/marine/19-4/368-376.pdf                     ;
  11. ;;                                                                            ;
  12. ;; Argument: l   List, Demanded Lengths in Decreasing order.                  ;
  13. ;;           d   List, Number of Corresponding Demanded Length.               ;
  14. ;;          ls   Real, Length of Standard Stock.                              ;
  15. ;;                                                                            ;
  16. ;; Returns: A List of Cutting Patterns, where each member is composed         ;
  17. ;;          of 3 items as follow: Item 1, Nb of times to apply Pattern.       ;
  18. ;;                                Item 2, List of integers where each         ;
  19. ;;                                        element correspond to the nb of     ;
  20. ;;                                        times to use a demanded length.     ;
  21. ;;                                Item 3, Waste per Bar for this Pattern.     ;
  22. ;;                                                                            ;
  23.  
  24. (defun 1D-CSP (l d ls / a ch cp idx maxint p tl sm pu v)
  25.    (setq maxint 2147483647)
  26.            
  27.    (while  (> (apply '+ d) 0)
  28.       (setq v (genpat l d ls nil) p nil)      
  29.       (foreach a v
  30.          (setq tl (- ls (apply '+ (mapcar '(lambda (a l) (* a l)) a l)))
  31.                sm (apply 'min (mapcar '(lambda (a d) (if (> a 0) (/ d a) maxint)) a d))
  32.                pu (* sm (apply '+ a))
  33.                 p (cons (list a tl sm pu) p)
  34.          )
  35.       )
  36.      
  37.       ; Here we Sort the Set of Patterns on Min tl, Max sm and Min pu         ;
  38.       ; The Chosen Pattern will bubble up to top of the list.                 ;
  39.      
  40.       (setq p (vl-sort (reverse p) '(lambda (a b) (if (= (cadr a) (cadr b))
  41.                                            (if (= (caddr a) (caddr b))
  42.                                               (< (cadddr a) (cadddr b))  
  43.                                               (> (caddr a) (caddr b))
  44.                                            )     
  45.                                            (< (cadr  a) (cadr  b))
  46.                                         )
  47.                           )
  48.               )
  49.       )
  50.      
  51.      
  52.       ; Building the Cutting Plan, then Adjusting the Demand List.            ;
  53.       ;(if (not (setq i (getint "\nChoose pattern : "))) 0)
  54.       (setq ch (car p))
  55.       (setq cp (cons (list (caddr ch) (pat2len (car ch) l) (cadr ch) ) cp))
  56.       (setq  d (mapcar '(lambda (d p) (- d (* p (caddr ch)))) d (car ch)))    
  57.    )  
  58.    (reverse cp)
  59. )
  60.  
  61.  
  62.  
  63.  
  64.  
  65. ;; genpat                  by ymg                                             ;
  66. ;;                                                                            ;
  67. ;; Procedure for Generating the Efficient Feasible Cutting Patterns           ;
  68. ;; http://www.cs.bham.ac.uk/~wbl/biblio/gecco2006/docs/p1675.pdf              ;
  69. ;; Appendix 1                                                                 ;
  70. ;; Part of "Cutting Stock Waste Reduction Using Genetic Algorithms"           ;
  71. ;;              by Y. Khalifa, O. Salem and A. Shahin                         ;
  72. ;;                                                                            ;
  73. ;; Argument: l   List, Demanded Lengths in Descending Order.                  ;
  74. ;;           d   List, Number of Corresponding Demanded Length.               ;
  75. ;;          ls   Real, Length of Standard Bar.                                ;
  76. ;;         all   Boolean, if true, Generate all Feasible Patterns.            ;
  77. ;;                        if false, Generates only the Set of Patterns        ;
  78. ;;                                  for the First Demand > 0                  ;
  79. ;;                                                                            ;
  80.  
  81. (defun genpat (l d ls all / a i j p  s)
  82.    (setq i 0) (while (zerop (nth i d)) (setq i (1+ i)))
  83.    (if (= (1+ i) (length d)) (setq all t))
  84.    (while (or (not a) (if all (> (apply '+ (cdr a)) 0) (> (nth i (reverse a)) 0)))
  85.       (cond
  86.           (a (setq a (cdr a))
  87.              (while (zerop (car a)) (setq a (cdr a)))
  88.              (setq a (cons (1- (car a)) (cdr a))
  89.                    j (length a)
  90.                    s (apply '+ (mapcar '(lambda (a l) (* a l)) (reverse a) l))
  91.              )
  92.            )
  93.            (t (setq j 0 s 0))
  94.       )  
  95.       (while (< j (length l))
  96.          (setq a (cons (min (floor (/ (- ls s) (nth j l))) (nth j d)) a)
  97.                s (+ s (* (car a) (nth j l)))
  98.                j (1+ j)
  99.          )
  100.       )
  101.       (setq p (cons (reverse a) p))
  102.    )  
  103.    (if all (reverse p) (reverse (cdr p)))
  104. )
  105.  
  106. (defun readcsv ( fname / str2lst f lin l)
  107.  
  108.     ; str2lst    by Gile Chanteau                                             ;
  109.     (defun str2lst (s d / p)
  110.         (if (setq p (vl-string-search d s))
  111.            (cons (substr s 1 p) (str2lst (substr s (+ p 2)) d))
  112.            (list s)
  113.         )
  114.     )
  115.  
  116.     (cond ((setq f (open (findfile fname) "r"))
  117.               (while (setq lin (read-line f))
  118.                  (setq l (cons (str2lst lin ",") l))
  119.               )
  120.               (close f)
  121.           )
  122.     )  
  123.     (reverse l)
  124. )
  125.  
  126. ;; massoc                                                                     ;
  127. ;;                                                                            ;
  128. ;; Returns a list of all items associated with the specified key              ;
  129. ;; in an association list.                                                    ;
  130. ;;                                                                            ;
  131. ;; Arguments:                                                                 ;
  132. ;;    k,  The value to search for in the list.                                ;
  133. ;;    l,  List of Associations                                                ;
  134. ;;                                                                            ;
  135.  
  136. (defun massoc (k l / i)       ; recursive version    ;
  137.     (if (setq i (assoc k l))
  138.        (cons (cdr i) (massoc k (cdr (member i l))))
  139.     )
  140. )
  141. (defun massoc (k l / i r)     ; Iterative version    ;
  142.     (while (setq i (assoc k l))
  143.         (setq r (cons (cdr i) r) l (cdr (member i l)))
  144.     )
  145.     (reverse r)
  146. )
  147.  
  148.  
  149. ;; distinct     by Gile Chanteau                                              ;
  150. ;; Deletes all duplicates in a list.                                          ;
  151. ;;                                                                            ;
  152. ;; Argument                                                                   ;
  153. ;; l   List                                                                   ;
  154. ;;                                                                            ;
  155.  
  156. (defun distinct (l) (if l (cons (car l) (distinct (vl-remove (car l) l)))))
  157.  
  158.  
  159. ;; distinct#    by ymg  (Derived from Distinct by Gile Chanteau               ;
  160. ;; Returns a list of distinct Item and Quantity ((item qty)......)            ;
  161. ;; Argument                                                                   ;
  162. ;; l   List                                                                   ;
  163. ;;                                                                            ;
  164.  
  165. ;(defun distinct# (l)
  166. ;   (if l
  167. ;     (cons (cons (car l) (- (length l) (length (setq l (vl-remove (car l) l))))) (distinct# l))    
  168. ;   )
  169. ;)
  170. ; Modified to return ((qty (pattern) waste) (...) (...))
  171. (defun distinct# (l / i)
  172.    (if l
  173.       (cons (cons (- (length l) (length (setq l (vl-remove (setq i (car l)) l)))) i) (distinct# l))    
  174.    )
  175. )
  176.  
  177. ;; Ceiling function, Returns the smallest integer not less than x.            ;
  178. (defun ceil  (x) (if (> (rem x 1) 0) (+ (fix x) 1) (fix x)))
  179. ;; Floor function, Returns the largest integer not greater than x.            ;
  180. (defun floor (x) (if (minusp (rem x 1)) (- (fix x) 1) (fix x)))
  181.  
  182.  
  183.  
  184. ;; FFD-binpack         by ymg                                                 ;
  185. ;; First Fit Decreasing                                                       ;
  186. ;; Arguments: l  List of items to put in bins                                 ;
  187. ;;            c  Capacity of a bin                                            ;
  188. ;;                                                                            ;
  189.  
  190. (defun FFD-binpack (l c / i b tb)
  191.    (foreach  i (vl-sort-i l '>)
  192.        (setq i (nth i l) tb nil)
  193.        (cond     
  194.           (b (while (and (> i (cadar b)) b)
  195.                (setq tb (cons (car b) tb)  b (cdr b))
  196.              )
  197.              (setq b (append (reverse (cons (list (reverse (cons i (reverse (caar b))))(if (cadar b) (- (cadar b) i) (- c i))) tb)) (cdr b)))
  198.           )
  199.           (t (setq b (list (list (list i) (- c i)))))
  200.        )         
  201.    )
  202. )
  203.  
  204.  
  205.  
  206. ;; longlst                                                                    ;
  207. ;; Expand a list of length and quantity into a long list with repeating items ;
  208. ;;                                                                            ;
  209. (defun longlst (l d / i j ll)
  210.   (setq j 0)
  211.   (foreach i d
  212.      (repeat i (setq ll (cons (nth j l) ll)))
  213.      (setq j (1+ j))
  214.   )
  215.   ll
  216. )
  217.  
  218. ;; pat2len                                                                    ;
  219. ;; Expand a pattern to length                                                 ;
  220. ;; (0 2 0 1 0) -> (l1 l1 l3)                                                  ;
  221. (defun pat2len (p l /  r)
  222.    (while p
  223.      (repeat (car p) (setq r (cons (car l) r)))
  224.         (setq l (cdr l) p (cdr p))
  225.    )
  226.    (reverse r)
  227. )
  228. ;; len2pat                                                                    ;
  229. ;; Inverse of pat2len                                                         ;
  230. ;; (l1 l1 l3) -> (0 2 0 1 0)                                                  ;
  231. (defun len2pat (p l)
  232.    (setq p (mapcar '(lambda (a) (cons (cdr a) (car a))) (distinct# p)))
  233.    (mapcar '(lambda (a) (if (setq c (assoc a p)) (cdr c) 0)) l)  
  234. )  
  235.  
  236. ;; printres                                                                   ;
  237. ;;                                                                            ;
  238. ;; Crude Patterns and Statistic Output to the Text Screen.                    ;
  239. ;;                                                                            ;
  240.  
  241. (defun printres (tit l d ls p / a su w)
  242.    (textscr)
  243.    (princ (strcat "\n" tit))
  244.    (princ (strcat "\n D: " (vl-princ-to-string d)))
  245.    (princ (strcat "\n L: " (vl-princ-to-string l)))
  246.    (princ (strcat "\nLs: " (if (= 'INT (type ls)) (itoa ls) (rtos ls 2 3))))
  247.    (princ "\n")
  248.    (foreach i p
  249.       (princ (strcat "\n" (vl-princ-to-string i)))
  250.    )
  251.    (princ "\n")
  252.    (princ (strcat "\nNb of Stock used    : " (itoa (setq su (apply '+ (mapcar 'car p))))))
  253.    (princ (strcat "\nNb of Parts Cut     : " (itoa (apply '+ (mapcar '(lambda (a) (* (car a) (length (cadr a)))) p)))))
  254.    (princ (strcat "\nTotal Length Wasted : " (if (= 'INT (type (setq w (apply '+ (mapcar '(lambda (a) (* (car a) (caddr a))) p))))) (itoa w) (rtos w 2 2))))
  255.    (princ (strcat "\nNb Patterns used    : " (itoa (length p))))
  256.    (princ (strcat "\nPercent Efficiency  : " (rtos (* 100 ( / (- (* su (float ls)) w) (* su ls))) 2 4) " %"))
  257.    (princ "\n\n")
  258. )
  259.  
  260.  
  261. (defun c:sergiu (/ a d data fn l ld ls size title)
  262.    (setq ls 12000)                            ; Length of Standard Bar                ;
  263.    (prompt "Select CSV File Containing Your Data :")
  264.    (setq fn (getfiled "Import CSV File" "" "csv" 8))
  265.          
  266.    (setq data (cdr (readcsv fn))              ; cdr is to discard the line of titles  ;
  267.          size (distinct (mapcar 'cadr data))  ; size is the list of distinct diameters;
  268.          data (mapcar '(lambda (a) (list (cadr a) (atoi (caddr a)) (atoi (last a)))) data)
  269.    )
  270.    ;; Data is now an association list and length and demand are in Integers.          ;
  271.  
  272.    (foreach diam size
  273.       (setq tit (strcat "File: " fn "  -  Cutting Patterns for Diam. " diam)
  274.              ld (vl-sort (massoc diam data) '(lambda (a b) (> (car a) (car b))))
  275.               l (mapcar 'car  ld)
  276.               d (mapcar 'cadr ld)          
  277.               p (1d-csp l d ls)
  278.       )
  279.       (printres (strcat "Dikili & Barlas - " tit) l d ls p)
  280.       (printres (strcat "FFD-binpack - " tit) l d ls (distinct# (ffd-binpack (longlst l d) ls)))
  281.    )  
  282.    (princ)  
  283. )
  284.  

ymg
« Last Edit: April 07, 2015, 05:54:46 AM by ymg »

ymg

  • Guest
emk2012,

You supply  list L, Length of bars needed.
You also supply list D, How many of each length are required.
You also give LS which is the length of the long bar from which
the smaller lengths are going to be cut.

The program then cut all the pieces, using two different methods
in order to minimize the waste.

Output is a set of cut patterns:


pBe

  • Bull Frog
  • Posts: 402
Good stuff YMG , i recently was introduced to the cutting stock problem. i ended up using First Fit Decreasing approach

I will look into this like now-now  ;D

;; Cutting Stock Problem as per approach described in:                       
;;                                                                           
;;               A GENERALIZED APPROACH TO THE SOLUTION                     
;;                  OF ONE-DIMENSIONAL STOCK-CUTTING                         
;;                    PROBLEM FOR SMALL SHIPYARDS.                           
;;              by Ahmet Cemil Dikili and Baris Barlas                       
;;                                                                           
;; Link:  http://jmst.ntou.edu.tw/marine/19-4/368-376.pdf                   

Thank you for the linky.  ;D

andy_lee

  • Newt
  • Posts: 147
emk2012,

You supply  list L, Length of bars needed.
You also supply list D, How many of each length are required.
You also give LS which is the length of the long bar from which
the smaller lengths are going to be cut.

The program then cut all the pieces, using two different methods
in order to minimize the waste.

Output is a set of cut patterns:

Thanks ymg, you did a good job.
andy.
Best regards.

ymg

  • Guest
pBe,

As I told before, you have to be careful with Dikili & Barlas
and compared with FFD-binpack.

I now have an Evolutionnary Programming solution, which shows
great promises.

Will publish once I figure the best way to stop generating solutions.
This is highly problem dependant but I seem to converge to good
solution within 500 generations.

Could also stop if solution fitness does not improve during, say, 50 generations.

Stay tuned!

ymg

pBe

  • Bull Frog
  • Posts: 402
.... I now have an Evolutionnary Programming solution, which shows
great promises......

Stay tuned!

ymg

That i will.  :)

ymg

  • Guest
Here is an implementation of the Evolutionnary Programming solution
to the Cutting Stock Problem as described in the following paper:

   A New Evolutionary Approach to Cutting Stock Problems With and Without Contiguity
   By: Ko-Hsin Liang, Xin Yao, Charles Newton, David Hoffman

This is again a text screen application.
I run it in the VLIDE editor.

Here is the code:
Code - Auto/Visual Lisp: [Select]
  1. ;;                       Example Problems                                     ;
  2. ;; From:                                                                      ;
  3. ;; Genetic algorithms for cutting stock problems: with and without contiguity ;
  4. ;;      by Hinterding R, Khan L.                                              ;
  5. ;;                                                                            ;
  6. ;;   http://vuir.vu.edu.au/25789/1/TECHNICALREPORT40_compressed.pdf           ;
  7. ;;                                                                            ;
  8.  
  9. (setq prob1ato5a
  10. '(("Problem 1a. Stock length 14 (20 items)                                  \n"
  11.   (3 4 5 6 7 8 9 10)
  12.   (5 2 1 2 4 2 1 3)
  13.   14)
  14.   ("Problem 2a  (50 items)                                                  \n"
  15.   (3 4 5 6 7 8 9 10)
  16.   (4 8 5 7 8 5 5 8)
  17.   15)
  18.   ("Problem 3a. Stock length 25 (60 items)                                  \n"
  19.   (3 4 5 6 7 8 9 10)
  20.   (6 12 6 5 15 6 4 6)
  21.   25)
  22.   ("Problem 4a. Stock length 25 (60 items)                                  \n"
  23.   (5 6 7 8 9 10 11 12)
  24.   (7 12 15 7 4 6 8 1)
  25.   25)
  26.   ("Problem 5a. Stock length 4300 (126 items)                               \n"
  27.   (2350 2250 2200 2100 2050 2000 1950 1900 1850 1700 1650 1350 1300 1250 1200 1150 1100 1050)
  28.   (2 4 4 15 6 11 6 15 13 5 2 9 3 6 10 4 8 3)
  29.   4300))
  30.   prob6a    
  31.   '(("Problem 6a. Stock length 86 (200 items)                                 \n"
  32.   (21 23 24 25 26 27 28 29 31 33 34 35 37 38 41 42 44 47)
  33.   (10 14 10 7 14 4 13 9 5 10 13 10 11 15 12 15 15 13)
  34.   86))
  35.   prob7a    
  36.   '(("Problem 7a. Stock length 120 (200 items)                                \n"
  37.   (22 26 27 28 29 30 31 32 34 36 37 38 39 46 47 48 52 53 54 56 58 60 63 64)
  38.   (6 3 14 12 9 15 11 10 11 13 4 3 6 14 7 3 14 9 7 3 5 14 4 3)
  39.   120))
  40.   prob8a    
  41.   '(("Problem 8a. Stock length 120 (400 items)                                \n"
  42.   (22 23 24 26 27 28 29 30 31 36 39 41 42 48 49 50 51 54 55 56 59 60 66 67)
  43.   (12 8 27 15 25 7 10 22 5 16 19 21 26 16 12 26 20 25 9 17 22 14 17 9)
  44.   120))
  45.   prob9a    
  46.   '(("Problem 9a. Stock length 120 (400 items)                                \n"
  47.   (21 22 24 25 27 29 30 31 32 33 34 35 38 39 42 44 45 46 47 48 49 50 51 52 53 54 55 56 57 59 60 61 63 65 66 67)
  48.   (13 15 7 5 9 9 3 15 18 17 4 17 20 9 4 19 9 12 15 3 20 14 15 6 4 7 5 19 19 6 3 7 20 5 10 17)
  49.   120))
  50.   prob10a    
  51.   '(("Problem 10a. Stock length 120 (600 items)                               \n"
  52.   (21 22 23 24 25 27 28 29 30 31 33 35 36 39 40 41 42 43 44 45 46 47 48 50 51 54 56 57 58 61 62 63 64 65 66 67)
  53.   (13 19 24 20 23 24 15 5 24 16 12 24 16 4 20 24 6 14 21 20 24 2 11 26 23 25 8 16 10 14 6 19 18 11 27 16)
  54.   120))
  55. )
  56.  
  57.  
  58. ;; EP-Cut              by ymg                                                 ;
  59. ;;                                                                            ;
  60. ;;        A New Evolutionary Approach to Cutting Stock Problems               ;
  61. ;;                  With and Without Contiguity                               ;
  62. ;;       By: Ko-Hsin Liang, Xin Yao, Charles Newton, David Hoffman          ;
  63. ;;  https://www.cs.bham.ac.uk/~xin/papers/COR_LiangYaoNewtonHoffman.pdf       ;
  64. ;;                                                                            ;
  65. ;; Contiguity is not implemented yet in the following                         ;
  66. ;;                                                                            ;
  67.  
  68. (defun c:EP-Cut (/ a b bc c cost d gmul graf i k l ls mn mu mx n n3ps ngen opp
  69.                    popu popuc prob  probc s st stid stidc stoc sz ti tit tsiz vexg w win)
  70.  
  71.             ; Notes that variables bsol, bcost, bstoc, sol, costc and stocc   ;
  72.             ; are not declared so that we can inspect other solutions.        ;
  73.             ; Sample problems also will need to bet to nil manually           ;
  74.  
  75.                  
  76.    (setq   mu 75             ; Size of Population                             ;
  77.          tsiz 10             ; Tournament Size (Number of Opponents)          ;
  78.          gmul 20             ; Multiplier for Nunber of Generation to Run     ;
  79.          n3ps  2             ; Number of 3PS Repetitions to Creates Offspring ;
  80.    )                        
  81.    (foreach pr prob1ato5a
  82.       (setq popu nil)
  83.       (setq ti (car (_vl-times)))
  84.       (setq tit (car   pr)
  85.               l (cadr  pr)
  86.               d (caddr pr)
  87.              ls (last  pr)
  88.       )
  89.       (setq popu (list (longlst l d)); Adding Ordered List eq. to FFD-binpack ;
  90.                n (length (car popu)) ; Nomber of Items to Cut                 ;
  91.             ngen (* gmul n)          ; Number of Generations to Run           ;
  92.             vexg (/ ngen 1.6)        ; Vertical Exageration for Graph         ;
  93.       )
  94.       (repeat (1- mu)
  95.          (setq popu (cons  (shuffle (car popu)) popu))
  96.       )
  97.       ; popu, Population                                                      ;
  98.       ; stoc, Population Decoded by First Fit Binpack                         ;
  99.       ; stid, Indices to popu to End of a Cut Stock                           ;
  100.       ; cost, Relative Cost of Each Individual                                ;
  101.       ; prob, Probability of Selecting a Given Stock for Mutations            ;
  102.      
  103.       (setq popu (reverse popu)
  104.             stoc (mapcar '(lambda (a) (ff-binpack a ls)) popu)
  105.             stid (mapcar '(lambda (a) (setq st -1) (mapcar '(lambda (a) (setq st (+ st (length (car a))))) a)) stoc)
  106.             cost (mapcar 'relcost  stoc)
  107.             prob (mapcar '(lambda (a) (mapcar '(lambda (a) (if (> (cadr a) 0) (/ 1.0 (sqrt (cadr a))) 0.01)) a)) stoc)
  108.                k 0
  109.       )
  110.       (setq    bc (apply 'min cost)
  111.             bstoc stoc
  112.             bcost cost
  113.              graf (list (list 0 (* vexg bc)))
  114.       )
  115.       (princ (strcat "\nEP-Cut - " tit ))
  116.       (princ (strcat "\nGeneration: " (itoa k) " \\ " (itoa ngen) "   -  Min. Cost: " (rtos bc 2 6)))
  117.      
  118.       ; Each Idividual in Population is Mutated by 3 Point Swap (3PS)         ;
  119.       (repeat ngen
  120.          (setq i 0 popuc nil)
  121.          (foreach ind popu
  122.             (repeat n3ps
  123.                (setq a (fix (* (rand) n))
  124.                      s (roulette (nth i prob))
  125.                     mx (nth s (nth i stid))
  126.                     mn (if (zerop s) 0 (+ (nth (1- s) (nth i stid)) 1))
  127.                      b (randrng mn mx)    
  128.                      s (roulette (nth i prob))
  129.                     mx (nth s (nth i stid))
  130.                     mn (if (zerop s) 0 (+ (nth (1- s) (nth i stid)) 1))
  131.                      c (randrng mn mx)    
  132.                    ind (swapnth a b ind)
  133.                    ind (swapnth a c ind)
  134.                )
  135.             )
  136.             (setq popuc (cons ind popuc)
  137.                   i (1+ i)
  138.             )      
  139.          )
  140.          (setq popuc (reverse popuc)
  141.                stocc (mapcar '(lambda (a) (ff-binpack a ls)) popuc)
  142.                stidc (mapcar '(lambda (a) (setq st -1) (mapcar '(lambda (a) (setq st (+ st (length (car a))))) a)) stocc)
  143.                costc (mapcar 'relcost  stocc)
  144.                probc (mapcar '(lambda (a) (mapcar '(lambda (a) (if (> (cadr a) 0) (/ 1.0 (sqrt (cadr a))) 0.01)) a)) stocc)
  145.                popuc (append popu popuc)
  146.                stocc (append stoc stocc)
  147.                stidc (append stid stidc)
  148.                costc (append cost costc)
  149.                probc (append prob probc)
  150.          )
  151.      
  152.          ; Conduct Comparisons Over the Union of Parents and Offspring        ;
  153.          ; Tournament Size is Defined at Beginning of Proram                  ;
  154.        
  155.          (setq i 0  sz (length costc) win nil)
  156.          (foreach c costc
  157.             (setq w 0)
  158.             (repeat tsiz
  159.                (while (= i (setq opp (fix (* (rand) sz)))))
  160.                (if (<= c (nth opp costc)) (setq w (1+ w)))
  161.             )
  162.             (setq win (cons w win)
  163.                     i (1+ i)
  164.             )      
  165.          )
  166.          (setq win (reverse win))
  167.            
  168.          ; Choose the Solution With Most Win for New Generation               ;
  169.        
  170.          (setq win (vl-sort-i win '>))
  171.          (setq popu nil stoc nil stid nil cost nil prob nil)       
  172.          (repeat mu
  173.             (setq    i (car win)  win (cdr win)
  174.                   popu (cons (nth i popuc) popu)
  175.                   stoc (cons (nth i stocc) stoc)
  176.                   stid (cons (nth i stidc) stid)
  177.                   cost (cons (nth i costc) cost)
  178.                   prob (cons (nth i probc) prob)
  179.             )
  180.          )
  181.          (setq popu (reverse popu)
  182.                stoc (reverse stoc)
  183.                stid (reverse stid)       
  184.                cost (reverse cost)
  185.                prob (reverse prob)       
  186.                   k (1+ k)
  187.         )
  188.         (setq    b (apply 'min costc)
  189.               graf (cons (list k (* vexg b)) graf)
  190.         )            
  191.         (if (< b bc)
  192.            (progn
  193.              (setq bc b bstoc stocc bcost costc)
  194.              (princ (strcat "\nGeneration: " (itoa k) " \\ " (itoa ngen) "   -  Min. Cost: " (rtos (apply 'min cost) 2 6)))            
  195.            )
  196.         )  
  197.      )
  198.      ; Order of the last 150 solutions in stocc                               ;
  199.      (setq sol (vl-sort-i bcost '<))  
  200.      (princ (strcat "\nGeneration: " (itoa k) " \\ " (itoa ngen) "   -  Min. Cost: " (rtos (apply 'min cost) 2 6)))
  201.      (princ (strcat "\n    EP-Cut - Elapsed time: " (rtos (/ (- (car (_vl-times)) ti) 1000.) 2 4) " secs. \n" ))
  202.      
  203.      
  204.      ; Here I am sorting all bins of the best solutions and outputting        ;
  205.      (setq bsol (mapcar '(lambda (a) (list (mapcar '(lambda (b) (nth b (car a))) (vl-sort-i (car a) '>)) (cadr a))) (nth (car sol) bstoc)))
  206.      (printres (strcat "EP-Cut - " tit) l d ls (distinct# bsol))
  207.      
  208.      ; Output the graph of Generations vs Cost for Debugging and Finding Best ;
  209.      ; way to stop the algorithm.                                             ;
  210.      (mk_lwp (reverse graf))          
  211.    ) ; Go to Next Problem    ;
  212.    (princ)
  213. )
  214.  
  215.  
  216. ;; longlst                                                                    ;
  217. ;; Expand a list of length and quantity to a                                  ;
  218. ;; Sorted long list with repeating items                                      ;
  219. ;;                                                                            ;
  220.  
  221. (defun longlst (l d / i j ll)
  222.   (setq j 0)
  223.   (foreach i d
  224.      (repeat i (setq ll (cons (nth j l) ll)))
  225.      (setq j (1+ j))
  226.   )
  227.   (mapcar '(lambda (a) (nth a ll)) (vl-sort-i ll '>))
  228. )
  229.  
  230.  
  231. ;; FF-binpack          by ymg                                                 ;
  232. ;; First Fit                                                                  ;
  233. ;; Arguments: l  List of items to put in bins                                 ;
  234. ;;            c  Capacity of a bin                                            ;
  235. ;;                                                                            ;
  236.  
  237. (defun FF-binpack (l c / i b tb)
  238.    (setq r nil)
  239.    (while l
  240.       (setq w ls b nil)
  241.       (while (and l (>= w (setq i (car l))))
  242.          (setq b (cons i b)
  243.                w (- w i)
  244.                l (cdr l)
  245.          )
  246.       )
  247.       (setq r (cons (list (reverse b) w) r))
  248.    )
  249.    (reverse r)
  250. )
  251.  
  252.  
  253. ;; Random number generator, #s(eed) remains Global.                           ;
  254.  
  255. (defun rand (/ x)
  256.    (/ (setq x 4294967296.0 #s (rem (1+ (* 1664525.0 (cond (#s) ((getvar 'DATE))))) x)) x)
  257. )
  258.  
  259. ;; Random in range i j  (Integer Range)                                       ;
  260.  
  261. (defun randrng (i j) (+ i (fix (* (rand) (- j i -1)))))
  262.  
  263. ;; roulette      by ymg                                                       ;
  264. ;;                                                                            ;
  265. ;; Roulette-Wheel Selection Via Stochastic Acceptance                         ;
  266. ;;    by Adam Lipowski and Dorota Lipowska                                    ;
  267. ;;          http://arxiv.org/pdf/1109.3627v2.pdf                              ;
  268. ;;                                                                            ;
  269. ;; Argument: l   List of Probabilities. (No need to normalize)                ;
  270. ;; Returns : Index in List of Chosen Item According to Probabilities.         ;
  271. ;;                                                                            ;
  272.  
  273. (defun roulette (l / k m n)
  274.    (setq  m (float (apply 'max l)) n (length l))
  275.    (while (> (rand) (/ (nth (setq k (fix (* (rand) n))) l) m)))
  276.    k
  277. )
  278.  
  279. ;; For Debugging Check Frquency of Returns of Roulette's Function             ;
  280. (defun checkroulette (/ l p r c0 c1 c2 c3 c4)
  281.    (setq l '((0.4 0.0 0.3 1.2 0.1)  ; Raw Probabilities                       ;
  282.              (0.2 0 0.15 0.6 0.05)) ; Same Probailities Normalized to 1       ;
  283.          r nil
  284.    )
  285.    (foreach p l
  286.       (setq c0 0 c1 0 c2 0 c3 0 c4 0)
  287.       (repeat 10000
  288.          (setq i (roulette p))
  289.          (cond
  290.             ((= i 0)(setq c0 (1+ c0)))
  291.             ((= i 1)(setq c1 (1+ c1)))
  292.             ((= i 2)(setq c2 (1+ c2)))
  293.             ((= i 3)(setq c3 (1+ c3)))
  294.             ((= i 4)(setq c4 (1+ c4))) 
  295.          )     
  296.       )
  297.       ; Should return close to (2000 0 1500 6000 500)                         ;
  298.       (setq r (cons (list c0 c1 c2 c3 c4) r))
  299.    )
  300.    (reverse r)
  301. )
  302.  
  303.  
  304. ;; relcost     by ymg                                                         ;
  305. ;;                                                                            ;
  306. ;; Calculates Relative Cost of Solution                                       ;
  307. ;; From: Genetic Algorithms for Cutting Stock Problems:                       ;
  308. ;;       With and Without Contiguity.                                         ;
  309. ;; By Robert Hinterding & Lutfar Khan                                         ;
  310. ;;      http://vuir.vu.edu.au/25789/1/TECHNICALREPORT40_compressed.pdf        ;
  311. ;;                                                                            ;
  312. ;; ls is defined in main program                                              ;
  313.  
  314. (defun relcost (l / m)
  315.    (setq m (length l))
  316.    (/ (apply '+
  317.          (mapcar '(lambda (a) (+ (sqrt (/ (cadr a) (float ls)))
  318.                                  (/ (if (zerop (cadr a)) 0 1.0) m)
  319.                               )
  320.                   )
  321.                   l
  322.          )
  323.       )
  324.       (1+ m)
  325.    )
  326. )
  327.  
  328.  
  329.  
  330. ;; swapnth     by ymg                                                         ;
  331. ;;                                                                            ;
  332. ;; Given Two Indices, n1 and n2 and a List l.                                 ;
  333. ;; Returns the List with the Item Position Swapped                            ;
  334. ;;                                                                            ;
  335.  
  336. (defun swapnth (n1 n2 l / a d tmp)
  337.    (setq d (1- (length l))
  338.          a (vlax-safearray-fill (vlax-make-safearray vlax-vbinteger (cons 0 d)) l)
  339.        tmp (vlax-safearray-get-element a n1)
  340.    )
  341.    (vlax-safearray-put-element a n1 (vlax-safearray-get-element a n2))
  342.    (vlax-safearray-put-element a n2 tmp)
  343.    (vlax-safearray->list a)
  344. )
  345.  
  346.  
  347. ; shuffle     (Original idea by highflyingbird)                               ;
  348. ;             Simplified the code   ymg                                       ;
  349.  
  350. (defun shuffle (l / a d  i  n tmp)
  351.    (setq d (1- (length l))
  352.          a (vlax-safearray-fill (vlax-make-safearray vlax-vbinteger (cons 0 d)) l)                    
  353.          i -1
  354.    )
  355.    (repeat d
  356.       (setq  i (1+ i)
  357.              n (+ i (fix (* (rand) (- d i))))  
  358.            tmp (vlax-safearray-get-element a n)
  359.       )
  360.       (vlax-safearray-put-element a n (vlax-safearray-get-element a i))
  361.       (vlax-safearray-put-element a i tmp)
  362.   )
  363.   (vlax-safearray->list a)
  364. )
  365.  
  366. ; This one by Irneb, list based. Actually quite fast, and even faster once    ;
  367. ; we replace repetitive call to function length by variable i                 ;
  368. ; in the vl-sort-i lambda clauses.                                            ;
  369.  
  370. (defun shuffle2 (l / p i)
  371.   (setq p (/ (setq i (length l)) 2))
  372.   (mapcar '(lambda (n) (nth n l))
  373.               (vl-sort-i l '(lambda (a b) (<= (fix (* (rand) i)) p)))))
  374.  
  375.  
  376.  
  377.  
  378. ;; mk_lwp    by Alan J Thompson                                                 ;
  379. ;; Argument: pl, A list of points (2d or 3d)                                    ;
  380. ;; Create an LWPolyline at Elevation 0, on Current Layer.                       ;
  381. ;; Return: Polyline Object                                                      ;
  382. ;;                                                                              ;
  383.  
  384. (defun mk_lwp (pl)
  385.     (vlax-ename->vla-object
  386.       (entmakex
  387.          (append (list '(0 . "LWPOLYLINE")
  388.                        '(100 . "AcDbEntity")
  389.                        '(100 . "AcDbPolyline")
  390.                         (cons 90 (length pl))
  391.                         '(70 . 0)
  392.                  )
  393.                  (mapcar '(lambda (p) (cons 10 (trans (list (car p) (cadr p)) 1 0))) pl)
  394.         )
  395.       )
  396.     )
  397.  )
  398.  
  399. ;; distinct#    by ymg  (Derived from Distinct by Gile Chanteau               ;
  400. ;; Returns a list of distinct Item and Quantity ((item qty)......)            ;
  401. ;; Argument                                                                   ;
  402. ;; l   List                                                                   ;
  403. ;;                                                                            ;
  404.  
  405. ;(defun distinct# (l)
  406. ;   (if l
  407. ;     (cons (cons (car l) (- (length l) (length (setq l (vl-remove (car l) l))))) (distinct# l))    
  408. ;   )
  409. ;)
  410.  
  411. ; Modified to return ((qty (pattern) waste) (...) (...))
  412. (defun distinct# (l / i)
  413.    (if l
  414.       (cons (cons (- (length l) (length (setq l (vl-remove (setq i (car l)) l)))) i) (distinct# l))    
  415.    )
  416. )
  417.  
  418.  
  419. ;; printres                                                                   ;
  420. ;;                                                                            ;
  421. ;; Crude Patterns and Statistic Output to the Text Screen.                    ;
  422. ;;                                                                            ;
  423.  
  424. (defun printres (tit l d ls p / a su w)
  425.    (textscr)
  426.    (princ (strcat "\n" tit))
  427.    (princ (strcat "\n D: " (vl-princ-to-string d)))
  428.    (princ (strcat "\n L: " (vl-princ-to-string l)))
  429.    (princ (strcat "\nLs: " (if (= 'INT (type ls)) (itoa ls) (rtos ls 2 3))))
  430.    (princ "\n")
  431.    (foreach i p
  432.       (princ (strcat "\n" (vl-princ-to-string i)))
  433.    )
  434.    (princ "\n")
  435.    (princ (strcat "\nNb of Stock used    : " (itoa (setq su (apply '+ (mapcar 'car p))))))
  436.    (princ (strcat "\nNb of Parts Cut     : " (itoa (apply '+ (mapcar '(lambda (a) (* (car a) (length (cadr a)))) p)))))
  437.    (princ (strcat "\nTotal Length Wasted : " (if (= 'INT (type (setq w (apply '+ (mapcar '(lambda (a) (* (car a) (caddr a))) p))))) (itoa w) (rtos w 2 2))))
  438.    (princ (strcat "\nNb Patterns used    : " (itoa (length p))))
  439.    (princ (strcat "\nPercent Efficiency  : " (rtos (* 100 ( / (- (* su (float ls)) w) (* su ls))) 2 4) " %"))
  440.    (princ "\n\n")
  441. )
  442.  

See continuation in next post.....
« Last Edit: April 10, 2015, 04:34:53 PM by ymg »

ymg

  • Guest
.......Continued from above.

The basic approach is to create a population of 75 permutations
of the items to be cut.

Each individuals in the Parent population is evaluated against a cost function.  It
then creates a single offspring by mutation (3 Points Swap) thus giving us a
CHILDREN population.

Each individuals in the Children population is also evaluated by the same cost function.

For each individual in the union of (Parent U Children) we select at random 10 opponents.
Each individual is compared  against all opponents.  For each comparison,
if the individual's cost is no greater than the opponent's, it receives a "WIN".

The 75 individuals with the most wins are elected to become the Parents for the Next generation.

Now still haven't figured a smart way to stop the generating.

Seems to be highly problem dependant.  For the moment I run (* 20 Nb itms to cut)
generations.

For Problem 1a to 4a it is more than sufficient.  At problem 5a it reaches the solution
however it is a tight fit.

Now I am open to suggestion If you play with it.

Next thing, I will implement the contiguous solution as it can be
an important factor in rebar cutting.

In parrallel I'm also working on an Ant Colony Optimization,
this one, Pattern based, could be faster than the above.

ymg
« Last Edit: April 10, 2015, 04:49:34 PM by ymg »

ymg

  • Guest
Here is revised code, faster mainly due
to the replacement of my swapnth routine
by CAB's excellent version of it.

CAB's version is nearly 3x faster  :embarrassed:

I've also done a bit of cleanup, but more
need to be done.

Code - Auto/Visual Lisp: [Select]
  1. ;; EP-Cut              by ymg                                                 ;
  2. ;;                                                                            ;
  3. ;;        A New Evolutionary Approach to Cutting Stock Problems               ;
  4. ;;                  With and Without Contiguity                               ;
  5. ;;       By: Ko-Hsin Liang, Xin Yao, Charles Newton, David Hoffman          ;
  6. ;;  https://www.cs.bham.ac.uk/~xin/papers/COR_LiangYaoNewtonHoffman.pdf       ;
  7. ;;                                                                            ;
  8. ;; Contiguity is not implemented yet in the following                         ;
  9. ;;                                                                            ;
  10.  
  11. (defun c:EP-Cut (/ a b bc c cost d gmul graf i k l ls mn mu mx n n3ps ngen opp
  12.                    popu popuc prob  probc s st stid stidc stoc sz ti tit tsiz vexg w win)
  13.  
  14.             ; Notes that variables bsol, bcost, bstoc, sol, costc and stocc   ;
  15.             ; are not declared so that we can inspect other solutions.        ;
  16.             ; Sample problems also will need to bet to nil manually           ;
  17.  
  18.                  
  19.    (setq   mu 75             ; Size of Population                             ;
  20.          tsiz 10             ; Tournament Size (Number of Opponents)          ;
  21.          gmul 20             ; Multiplier for Nunber of Generation to Run     ;
  22.          n3ps  2             ; Number of 3PS Repetitions to Creates Offspring ;
  23.    )                        
  24.    (foreach pr prob1ato5a
  25.       (setq popu nil)
  26.       (setq ti (car (_vl-times)))
  27.       (setq tit (car   pr)
  28.               l (cadr  pr)
  29.               d (caddr pr)
  30.              ls (last  pr)
  31.       )
  32.       (setq popu (list (longlst l d)); Adding Ordered List eq. to FFD-binpack ;
  33.                n (length (car popu)) ; Nomber of Items to Cut                 ;
  34.             ngen (* gmul n)          ; Number of Generations to Run           ;
  35.             vexg (/ ngen 1.6)        ; Vertical Exageration for Graph         ;
  36.       )
  37.       (repeat (1- mu)
  38.          (setq popu (cons  (shuffle (car popu)) popu))
  39.       )
  40.      
  41.       ; popu, Population                                                      ;
  42.       ; stoc, Population Decoded by First Fit Binpack                         ;
  43.       ; stid, Indices to popu to End of a Cut Stock                           ;
  44.       ; prob, Probability of Selecting a Given Stock for Mutations            ;
  45.       ; cost, Relative Cost of Each Individual                                ;
  46.      
  47.       (setq popu (reverse popu)
  48.             stoc (mapcar '(lambda (a) (ff-binpack a ls)) popu)
  49.             stid (mapcar '(lambda (a) (setq st -1) (mapcar '(lambda (a) (setq st (+ st (length (car a))))) a)) stoc)
  50.             prob (mapcar '(lambda (a) (mapcar '(lambda (a) (if (> (cadr a) 0) (/ 1.0 (sqrt (cadr a))) 0.01)) a)) stoc)
  51.             cost (mapcar 'relcost  stoc)
  52.             k 0
  53.       )
  54.       (setq    bc (apply 'min cost)
  55.             bstoc stoc
  56.             bcost cost
  57.              graf (list (list 0 (* vexg bc)))
  58.       )
  59.       (princ (strcat "\nEP-Cut - " tit ))
  60.       (princ (strcat "\nGeneration: " (itoa k) " \\ " (itoa ngen) "   -  Min. Cost: " (rtos bc 2 9)))
  61.      
  62.       ; Each Idividual in Population is Mutated by 3 Point Swap (3PS)         ;
  63.       (repeat ngen
  64.          (setq i 0 popuc nil)
  65.          (foreach ind popu
  66.             (repeat n3ps
  67.                (setq a (fix (* (rand) n))
  68.                      s (roulette (nth i prob))
  69.                     mx (nth s (nth i stid))
  70.                     mn (if (zerop s) 0 (+ (nth (1- s) (nth i stid)) 1))
  71.                      b (randrng mn mx)    
  72.                      s (roulette (nth i prob))
  73.                     mx (nth s (nth i stid))
  74.                     mn (if (zerop s) 0 (+ (nth (1- s) (nth i stid)) 1))
  75.                      c (randrng mn mx)    
  76.                    ind (swapnth a b ind)
  77.                    ind (swapnth a c ind)
  78.                )
  79.             )
  80.             (setq popuc (cons ind popuc)
  81.                   i (1+ i)
  82.             )      
  83.          )
  84.        
  85.          (setq popuc (reverse popuc)
  86.                stocc (mapcar '(lambda (a) (ff-binpack a ls)) popuc)
  87.                stidc (mapcar '(lambda (a) (setq st -1) (mapcar '(lambda (a) (setq st (+ st (length (car a))))) a)) stocc)
  88.                probc (mapcar '(lambda (a) (mapcar '(lambda (a) (if (> (cadr a) 0) (/ 1.0 (sqrt (cadr a))) 0.01)) a)) stocc)
  89.                costc (mapcar 'relcost  stocc)
  90.                
  91.                popuc (append popu popuc)
  92.                stocc (append stoc stocc)
  93.                stidc (append stid stidc)
  94.                probc (append prob probc)
  95.                costc (append cost costc)
  96.          )
  97.      
  98.          ; Conduct Comparisons Over the Union of Parents and Offspring        ;
  99.          ; Tournament Size is Defined at Beginning of Proram                  ;
  100.        
  101.          (setq i 0  sz (+ mu mu) win nil)
  102.          (foreach c costc
  103.             (setq w 0)
  104.             (repeat tsiz
  105.                (while (= i (setq opp (fix (* (rand) sz)))))
  106.                (if (<= c (nth opp costc)) (setq w (1+ w)))
  107.             )
  108.             (setq win (cons w win)
  109.                     i (1+ i)
  110.             )      
  111.          )
  112.          
  113.            
  114.          ; Choose the Solution With Most Win for New Generation               ;
  115.        
  116.          (setq  win (take mu (vl-sort-i (reverse win) '>))
  117.                popu (mapcar '(lambda (a) (nth a popuc)) win)
  118.                stoc (mapcar '(lambda (a) (nth a stocc)) win)
  119.                stid (mapcar '(lambda (a) (nth a stidc)) win)
  120.                prob (mapcar '(lambda (a) (nth a probc)) win)
  121.                cost (mapcar '(lambda (a) (nth a costc)) win)
  122.                   k (1+ k)
  123.          )
  124.                   (vl-sort-i win '>)
  125.         (setq    b (apply 'min costc)
  126.               graf (cons (list k (* vexg b)) graf)
  127.         )            
  128.         (if (< b bc)
  129.            (progn
  130.              (setq bc b bstoc stocc bcost costc)
  131.              (princ (strcat "\nGeneration: " (itoa k) " \\ " (itoa ngen) "   -  Min. Cost: " (rtos (apply 'min cost) 2 9)))            
  132.            )
  133.         )  
  134.      )
  135.      ; Order of the last 150 solutions in stocc                               ;
  136.      (setq sol (vl-sort-i bcost '<))  
  137.      (princ (strcat "\nGeneration: " (itoa k) " \\ " (itoa ngen) "   -  Min. Cost: " (rtos (apply 'min cost) 2 9)))
  138.      (princ (strcat "\n    EP-Cut - Elapsed time: " (rtos (/ (- (car (_vl-times)) ti) 1000.) 2 4) " secs. \n" ))
  139.      
  140.      
  141.      ; Here I am sorting all bins of the best solutions and outputting        ;
  142.      (setq bsol (mapcar '(lambda (a) (list (mapcar '(lambda (b) (nth b (car a))) (vl-sort-i (car a) '>)) (cadr a))) (nth (car sol) bstoc)))
  143.      (printres (strcat "EP-Cut - " tit) l d ls (distinct# bsol))
  144.      
  145.      ; Output the graph of Generations vs Cost for Debugging and Finding Best ;
  146.      ; way to stop the algorithm.                                             ;
  147.      (mk_lwp (reverse graf))          
  148.    ) ; Go to Next Problem    ;
  149.    (princ)
  150. )
  151.  
  152.  
  153. ;; longlst                                                                    ;
  154. ;; Expand a list of length and quantity to a                                  ;
  155. ;; Sorted long list with repeating items                                      ;
  156. ;;                                                                            ;
  157.  
  158. (defun longlst (l d / i j ll)
  159.   (setq j 0)
  160.   (foreach i d
  161.      (repeat i (setq ll (cons (nth j l) ll)))
  162.      (setq j (1+ j))
  163.   )
  164.   (mapcar '(lambda (a) (nth a ll)) (vl-sort-i ll '>))
  165. )
  166.  
  167.  
  168. ;; FF-binpack          by ymg                                                 ;
  169. ;; First Fit                                                                  ;
  170. ;; Arguments: l  List of items to put in bins                                 ;
  171. ;;            c  Capacity of a bin                                            ;
  172. ;;                                                                            ;
  173.  
  174. (defun FF-binpack (l c / i b tb)
  175.    (setq r nil)
  176.    (while l
  177.       (setq w ls b nil)
  178.       (while (and l (>= w (setq i (car l))))
  179.          (setq b (cons i b)
  180.                w (- w i)
  181.                l (cdr l)
  182.          )
  183.       )
  184.       (setq r (cons (list (reverse b) w) r))
  185.    )
  186.    (reverse r)
  187. )
  188.  
  189.  
  190. ;; Random number generator, #s(eed) remains Global.                           ;
  191.  
  192. (defun rand (/ x)
  193.    (/ (setq x 4294967296.0 #s (rem (1+ (* 1664525.0 (cond (#s) ((getvar 'DATE))))) x)) x)
  194. )
  195.  
  196. ;; Random in range i j  (Integer Range)                                       ;
  197.  
  198. (defun randrng (i j) (+ i (fix (* (rand) (- j i -1)))))
  199.  
  200. ;; roulette      by ymg                                                       ;
  201. ;;                                                                            ;
  202. ;; Roulette-Wheel Selection Via Stochastic Acceptance                         ;
  203. ;;    by Adam Lipowski and Dorota Lipowska                                    ;
  204. ;;          http://arxiv.org/pdf/1109.3627v2.pdf                              ;
  205. ;;                                                                            ;
  206. ;; Argument: l   List of Probabilities. (No need to normalize)                ;
  207. ;; Returns : Index in List of Chosen Item According to Probabilities.         ;
  208. ;;                                                                            ;
  209.  
  210. (defun roulette (l / k m n)
  211.    (setq  m (float (apply 'max l)) n (length l))
  212.    (while (> (rand) (/ (nth (setq k (fix (* (rand) n))) l) m)))
  213.    k
  214. )
  215.  
  216. ;; For Debugging Check Frquency of Returns of Roulette's Function             ;
  217. (defun checkroulette (/ l p r c0 c1 c2 c3 c4)
  218.    (setq l '((0.4 0.0 0.3 1.2 0.1)  ; Raw Probabilities                       ;
  219.              (0.2 0 0.15 0.6 0.05)) ; Same Probailities Normalized to 1       ;
  220.          r nil
  221.    )
  222.    (foreach p l
  223.       (setq c0 0 c1 0 c2 0 c3 0 c4 0)
  224.       (repeat 10000
  225.          (setq i (roulette p))
  226.          (cond
  227.             ((= i 0)(setq c0 (1+ c0)))
  228.             ((= i 1)(setq c1 (1+ c1)))
  229.             ((= i 2)(setq c2 (1+ c2)))
  230.             ((= i 3)(setq c3 (1+ c3)))
  231.             ((= i 4)(setq c4 (1+ c4))) 
  232.          )     
  233.       )
  234.       ; Should return close to (2000 0 1500 6000 500)                         ;
  235.       (setq r (cons (list c0 c1 c2 c3 c4) r))
  236.    )
  237.    (reverse r)
  238. )
  239.  
  240.  
  241. ;; relcost     by ymg                                                         ;
  242. ;;                                                                            ;
  243. ;; Calculates Relative Cost of Solution                                       ;
  244. ;; From: Genetic Algorithms for Cutting Stock Problems:                       ;
  245. ;;       With and Without Contiguity.                                         ;
  246. ;; By Robert Hinterding & Lutfar Khan                                         ;
  247. ;;      http://vuir.vu.edu.au/25789/1/TECHNICALREPORT40_compressed.pdf        ;
  248. ;;                                                                            ;
  249. ;; ls is defined in main program                                              ;
  250.  
  251. (defun relcost (l / m)
  252.    (setq m (length l))
  253.    (/ (apply '+
  254.          (mapcar '(lambda (a) (+ (sqrt (/ (cadr a) (float ls)))
  255.                                  (/ (if (zerop (cadr a)) 0 1.0) m)
  256.                               )
  257.                   )
  258.                   l
  259.          )
  260.       )
  261.       (1+ m)
  262.    )
  263. )
  264.  
  265.  
  266.  
  267. ;; swapnth     by ymg                                                         ;
  268. ;;                                                                            ;
  269. ;; Given Two Indices, n1 and n2 and a List l.                                 ;
  270. ;; Returns the List with the Item Position Swapped                            ;
  271. ;;                                                                            ;
  272.  
  273. (defun swapnth (n1 n2 l / a d tmp)
  274.    (setq d (1- (length l))
  275.          a (vlax-safearray-fill (vlax-make-safearray vlax-vbinteger (cons 0 d)) l)
  276.        tmp (vlax-safearray-get-element a n1)
  277.    )
  278.    (vlax-safearray-put-element a n1 (vlax-safearray-get-element a n2))
  279.    (vlax-safearray-put-element a n2 tmp)
  280.    (vlax-safearray->list a)
  281. )
  282.  
  283. ;; swapnth     by CAB    (3 times faster than above)                          ;
  284. ;;                                                                            ;
  285. ;; Given Two Indices, n1 and n2 and a List l.                                 ;
  286. ;; Returns the List with the Item Position Swapped                            ;
  287. ;; Notes: I've removed the arguments testing.                                 ;
  288. ;; (if (and (< -1 i1 (length lst)) (< -1 i2 (length lst)))                    ;
  289.  
  290. (defun swapnth (n1 n2 l / i)
  291.   (setq i -1)
  292.     (mapcar '(lambda (a)
  293.                (setq i (1+ i))
  294.                (cond
  295.                  ((= i n2) (nth n1 l))
  296.                  ((= i n1) (nth n2 l))
  297.                  (a)
  298.                )
  299.              )
  300.         l
  301.     )
  302. )
  303.  
  304.  
  305. ; shuffle     (Original idea by highflyingbird)                               ;
  306. ;             Simplified the code   ymg                                       ;
  307.  
  308. (defun shuffle (l / a d  i  n tmp)
  309.    (setq d (1- (length l))
  310.          a (vlax-safearray-fill (vlax-make-safearray vlax-vbinteger (cons 0 d)) l)                    
  311.          i -1
  312.    )
  313.    (repeat d
  314.       (setq  i (1+ i)
  315.              n (+ i (fix (* (rand) (- d i))))  
  316.            tmp (vlax-safearray-get-element a n)
  317.       )
  318.       (vlax-safearray-put-element a n (vlax-safearray-get-element a i))
  319.       (vlax-safearray-put-element a i tmp)
  320.   )
  321.   (vlax-safearray->list a)
  322. )
  323.  
  324. ; This one by Irneb, list based. Actually quite fast, and even faster once    ;
  325. ; we replace repetitive call to function length by variable i                 ;
  326. ; in the vl-sort-i lambda clauses.                                            ;
  327.  
  328. (defun shuffle2 (l / p i)
  329.   (setq p (/ (setq i (length l)) 2))
  330.   (mapcar '(lambda (n) (nth n l))
  331.               (vl-sort-i l '(lambda (a b) (<= (fix (* (rand) i)) p)))))
  332.  
  333.  
  334.  
  335.  
  336. ;; mk_lwp    by Alan J Thompson                                                 ;
  337. ;; Argument: pl, A list of points (2d or 3d)                                    ;
  338. ;; Create an LWPolyline at Elevation 0, on Current Layer.                       ;
  339. ;; Return: Polyline Object                                                      ;
  340. ;;                                                                              ;
  341.  
  342. (defun mk_lwp (pl)
  343.     (vlax-ename->vla-object
  344.       (entmakex
  345.          (append (list '(0 . "LWPOLYLINE")
  346.                        '(100 . "AcDbEntity")
  347.                        '(100 . "AcDbPolyline")
  348.                         (cons 90 (length pl))
  349.                         '(70 . 0)
  350.                  )
  351.                  (mapcar '(lambda (p) (cons 10 (trans (list (car p) (cadr p)) 1 0))) pl)
  352.         )
  353.       )
  354.     )
  355.  )
  356.  
  357. ;; distinct#    by ymg  (Derived from Distinct by Gile Chanteau               ;
  358. ;; Returns a list of distinct Item and Quantity ((item qty)......)            ;
  359. ;; Argument                                                                   ;
  360. ;; l   List                                                                   ;
  361. ;;                                                                            ;
  362.  
  363. ;(defun distinct# (l)
  364. ;   (if l
  365. ;     (cons (cons (car l) (- (length l) (length (setq l (vl-remove (car l) l))))) (distinct# l))    
  366. ;   )
  367. ;)
  368.  
  369. ; Modified to return ((qty (pattern) waste) (...) (...))
  370. (defun distinct# (l / i)
  371.    (if l
  372.       (cons (cons (- (length l) (length (setq l (vl-remove (setq i (car l)) l)))) i) (distinct# l))    
  373.    )
  374. )
  375.  
  376. ; take   by ymg                                                               ;
  377. ;                                                                             ;
  378. ; Returns the first n items from a list as a list                             ;
  379. ;                                                                             ;
  380. ; Iterative version of Gile Chanteau's take                                   ;
  381.  
  382. (defun take (n l / r)
  383.    (repeat n
  384.       (setq r (cons (car l) r) l (cdr l))
  385.    )
  386.    (reverse r)
  387. )
  388.  
  389.  
  390. ;; printres                                                                   ;
  391. ;;                                                                            ;
  392. ;; Crude Patterns and Statistic Output to the Text Screen.                    ;
  393. ;;                                                                            ;
  394.  
  395. (defun printres (tit l d ls p / a su w)
  396.    ;(textscr)
  397.    (princ (strcat "\n" tit))
  398.    (princ (strcat "\n D: " (vl-princ-to-string d)))
  399.    (princ (strcat "\n L: " (vl-princ-to-string l)))
  400.    (princ (strcat "\nLs: " (if (= 'INT (type ls)) (itoa ls) (rtos ls 2 3))))
  401.    (princ "\n")
  402.    (foreach i p
  403.       (princ (strcat "\n" (vl-princ-to-string i)))
  404.    )
  405.    (princ "\n")
  406.    (princ (strcat "\nNb of Stock used    : " (itoa (setq su (apply '+ (mapcar 'car p))))))
  407.    (princ (strcat "\nNb of Parts Cut     : " (itoa (apply '+ (mapcar '(lambda (a) (* (car a) (length (cadr a)))) p)))))
  408.    (princ (strcat "\nTotal Length Wasted : " (if (= 'INT (type (setq w (apply '+ (mapcar '(lambda (a) (* (car a) (caddr a))) p))))) (itoa w) (rtos w 2 2))))
  409.    (princ (strcat "\nNb Patterns used    : " (itoa (length p))))
  410.    (princ (strcat "\nPercent Efficiency  : " (rtos (* 100 ( / (- (* su (float ls)) w) (* su ls))) 2 4) " %"))
  411.    (princ "\n\n")
  412. )
  413.  

ymg

  • Guest
Here again, revised code with some
more speed improvements.

I've settled the issue of stopping the generation
loop.  As of now the loop executes for at least
400 generations past the last generation, where
there was an improvement in cost, unless we reach
a cost of 0.0 in which case we Exit.

(Note: this much more than my initial guess of 50)

I will now concentrate on implementing the
"Contiguity" constraint, before trying to do
any more speed improvements.


Code - Auto/Visual Lisp: [Select]
  1. ;; EP-Cut              by ymg                                                 ;
  2. ;;                                                                            ;
  3. ;;        A New Evolutionary Approach to Cutting Stock Problems               ;
  4. ;;                  With and Without Contiguity                               ;
  5. ;;       By: Ko-Hsin Liang, Xin Yao, Charles Newton, David Hoffman          ;
  6. ;;  https://www.cs.bham.ac.uk/~xin/papers/COR_LiangYaoNewtonHoffman.pdf       ;
  7. ;;                                                                            ;
  8. ;; Contiguity is not implemented yet in the following                         ;
  9. ;;                                                                            ;
  10.  
  11. (defun c:EP-Cut (/ a b bc c cost d gmul graf i k l ls mn mu mx n n3ps ngen opp
  12.                    popu popuc prob  probc s st stid stidc stoc sz ti tit tsiz vexg w win)
  13.  
  14.             ; Notes that variables bsol, bcost, bstoc, sol, costc and stocc   ;
  15.             ; are not declared so that we can inspect other solutions.        ;
  16.             ; Sample problems also will need to bet to nil manually           ;
  17.  
  18.                  
  19.    (setq   mu 75             ; Size of Population                             ;
  20.          tsiz 10             ; Tournament Size (Number of Opponents)          ;
  21.          gmul 20             ; Multiplier for Max # of Generation to Run      ;
  22.          n3ps  2             ; Number of 3PS Repetitions to Creates Offspring ;
  23.          stop 400            ; Exit Loop if Best Cost Show no Improvement     ;
  24.    )                        
  25.    (foreach pr prob1ato5a
  26.       (setq popu nil)
  27.       (setq ti (car (_vl-times)))
  28.       (setq tit (car   pr)
  29.               l (cadr  pr)
  30.               d (caddr pr)
  31.              ls (last  pr)
  32.       )
  33.       (setq popu (list (longlst l d)); Adding Ordered List eq. to FFD-binpack ;
  34.                n (length (car popu)) ; Nomber of Items to Cut                 ;
  35.       )
  36.       (repeat (1- mu)
  37.          (setq popu (cons  (shuffle (car popu)) popu))
  38.       )
  39.      
  40.       ; popu, Population                                                      ;
  41.       ; stoc, Population Decoded by First Fit Binpack                         ;
  42.       ; stid, Indices to popu to Start of a Cut Stock                         ;
  43.       ; prob, Probability of Selecting a Given Stock for Mutations            ;
  44.       ; cost, Relative Cost of Each Individual                                ;
  45.      
  46.       (setq popu (reverse popu)
  47.             stoc (mapcar '(lambda (a) (ff-binpack a ls)) popu)
  48.             stid (mapcar '(lambda (a) (setq i 0) (cons 0 (mapcar '(lambda (a) (setq i (+ i (length (car a))))) a))) stoc)
  49.             prob (mapcar '(lambda (a) (mapcar '(lambda (a) (if (> (cadr a) 0) (/ 1.0 (sqrt (cadr a))) 0.01)) a)) stoc)
  50.             cost (mapcar 'relcost  stoc)
  51.             k 0
  52.       )
  53.       (setq    bc (apply 'min cost)         ; Best Cost So Far                ;
  54.             bstoc stoc                      ; Copy of stoc List               ;
  55.             bcost cost                      ; Copy of cost List               ;
  56.                bk 0                         ; Generation# of Best Cost        ;
  57.              ngen (+ bk stop)              
  58.       )
  59.       (princ (strcat "\nEP-Cut - " tit ))
  60.       (princ (strcat "\nGeneration: " (itoa k) " \\ " (itoa ngen) "   -  Min. Cost: " (rtos bc 2 9)))
  61.      
  62.       ; Each Idividual in Population is Mutated by 3 Point Swap (3PS)         ;
  63.       (while (and (< (- k bk) stop) (> bc 0))
  64.          (setq i 0 popuc nil)
  65.          (foreach ind popu
  66.             (setq pro (nth i prob) sti (nth i stid))
  67.             (setq a (fix (* (rand) n))
  68.                      s (roulette pro)
  69.                     mn (nth s sti)
  70.                     mx (1- (nth (1+ s) sti))
  71.                      b (randrng mn mx)    
  72.                      s (roulette pro)
  73.                     mn (nth s sti)
  74.                     mx (1- (nth (1+ s) sti))               
  75.                      c (randrng mn mx)    
  76.                    ind (swapnth a b ind)
  77.                    ind (swapnth a c ind)
  78.             )
  79.             (setq popuc (cons ind popuc)
  80.                   i (1+ i)
  81.             )      
  82.          )
  83.          
  84.          (setq popuc (reverse popuc)
  85.                stocc (mapcar '(lambda (a) (ff-binpack a ls)) popuc)
  86.                stidc (mapcar '(lambda (a) (setq i 0) (cons 0 (mapcar '(lambda (a) (setq i (+ i (length (car a))))) a))) stocc)
  87.                probc (mapcar '(lambda (a) (mapcar '(lambda (a) (if (> (cadr a) 0) (/ 1.0 (sqrt (cadr a))) 0.01)) a)) stocc)
  88.                costc (mapcar 'relcost  stocc)
  89.                
  90.                popuc (append popu popuc)
  91.                stocc (append stoc stocc)
  92.                stidc (append stid stidc)
  93.                probc (append prob probc)
  94.                costc (append cost costc)
  95.          )
  96.      
  97.          ; Conduct Comparisons Over the Union of Parents and Offspring        ;
  98.          ; Tournament Size is Defined at Beginning of Proram                  ;
  99.        
  100.          (setq i 0  u (+ mu mu) win nil b 1.0)
  101.          (foreach c costc
  102.             (setq w 0)
  103.             (repeat tsiz
  104.                (while (= i (setq opp (fix (* (rand) u)))))
  105.                (if (<= c (nth opp costc)) (setq w (1+ w)))
  106.             )
  107.             (setq win (cons w win)
  108.                     i (1+ i)
  109.             )      
  110.          )
  111.          
  112.            
  113.          ; Choose the Solution With Most Win for New Generation               ;
  114.        
  115.          (setq  win (take mu (vl-sort-i (reverse win) '>))
  116.                popu (mapcar '(lambda (a) (nth a popuc)) win)
  117.                stoc (mapcar '(lambda (a) (nth a stocc)) win)
  118.                stid (mapcar '(lambda (a) (nth a stidc)) win)
  119.                prob (mapcar '(lambda (a) (nth a probc)) win)
  120.                cost (mapcar '(lambda (a) (setq b (min b (setq a (nth a costc)))) a) win)
  121.                   k (1+ k)
  122.          )
  123.                  
  124.          (if (< b bc)
  125.             (setq    bc b
  126.                      bk k
  127.                   bstoc stocc
  128.                   bcost costc
  129.                   ngen (+ bk stop)  
  130.                     ** (princ (strcat "\nGeneration: " (itoa k) " \\ " (itoa ngen) "   -  Min. Cost: " (rtos b 2 9)))            
  131.            )
  132.         )  
  133.      ) ; Goto next generation ;
  134.      
  135.      ; Order of the last 150 solutions in stocc                               ;
  136.      (setq sol (vl-sort-i bcost '<))  
  137.      (princ (strcat "\nGeneration: " (itoa k) " \\ " (itoa ngen) "   -  Min. Cost: " (rtos b 2 9)))
  138.      (princ (strcat "\n    EP-Cut - Elapsed time: " (rtos (/ (- (car (_vl-times)) ti) 1000.) 2 4) " secs. \n" ))
  139.      
  140.      
  141.      ; Here Sorting the Cuts in Best Solutions and Outputting                 ;
  142.      (setq bsol (mapcar '(lambda (a) (list (mapcar '(lambda (b) (nth b (car a))) (vl-sort-i (car a) '>)) (cadr a))) (nth (car sol) bstoc)))
  143.      (printres (strcat "EP-Cut - " tit) l d ls (distinct# bsol))
  144.      
  145.              
  146.    ) ; Go to Next Problem    ;
  147.    (princ)
  148. )
  149.  
  150.  
  151. ;; longlst                                                                    ;
  152. ;; Expand a list of length and quantity to a                                  ;
  153. ;; Sorted long list with repeating items                                      ;
  154. ;;                                                                            ;
  155.  
  156. (defun longlst (l d / i j ll)
  157.   (setq j 0)
  158.   (foreach i d
  159.      (repeat i (setq ll (cons (nth j l) ll)))
  160.      (setq j (1+ j))
  161.   )
  162.   (mapcar '(lambda (a) (nth a ll)) (vl-sort-i ll '>))
  163. )
  164.  
  165.  
  166. ;; FF-binpack          by ymg                                                 ;
  167. ;; First Fit                                                                  ;
  168. ;; Arguments: l  List of items to put in bins                                 ;
  169. ;;            c  Capacity of a bin                                            ;
  170. ;;                                                                            ;
  171.  
  172. (defun FF-binpack (l c / i b tb)
  173.    (setq r nil)
  174.    (while l
  175.       (setq w ls b nil)
  176.       (while (and l (>= w (setq i (car l))))
  177.          (setq b (cons i b)
  178.                w (- w i)
  179.                l (cdr l)
  180.          )
  181.       )
  182.       (setq r (cons (list (reverse b) w) r))
  183.    )
  184.    (reverse r)
  185. )
  186.  
  187.  
  188. ;; Random number generator, #s(eed) remains Global.                           ;
  189.  
  190. (defun rand (/ x)
  191.    (/ (setq x 4294967296.0 #s (rem (1+ (* 1664525.0 (cond (#s) ((getvar 'DATE))))) x)) x)
  192. )
  193.  
  194. ;; Random in range i j  (Integer Range)                                       ;
  195.  
  196. (defun randrng (i j) (+ i (fix (* (rand) (- j i -1)))))
  197.  
  198. ;; roulette      by ymg                                                       ;
  199. ;;                                                                            ;
  200. ;; Roulette-Wheel Selection Via Stochastic Acceptance                         ;
  201. ;;    by Adam Lipowski and Dorota Lipowska                                    ;
  202. ;;          http://arxiv.org/pdf/1109.3627v2.pdf                              ;
  203. ;;                                                                            ;
  204. ;; Argument: l   List of Probabilities. (No need to normalize)                ;
  205. ;; Returns : Index in List of Chosen Item According to Probabilities.         ;
  206. ;;                                                                            ;
  207.  
  208. (defun roulette (l / k m n)
  209.    (setq  m (float (apply 'max l)) n (length l))
  210.    (while (> (rand) (/ (nth (setq k (fix (* (rand) n))) l) m)))
  211.    k
  212. )
  213.  
  214. ;; For Debugging Check Frquency of Returns of Roulette's Function             ;
  215. (defun checkroulette (/ l p r c0 c1 c2 c3 c4)
  216.    (setq l '((0.4 0.0 0.3 1.2 0.1)  ; Raw Probabilities                       ;
  217.              (0.2 0 0.15 0.6 0.05)) ; Same Probailities Normalized to 1       ;
  218.          r nil
  219.    )
  220.    (foreach p l
  221.       (setq c0 0 c1 0 c2 0 c3 0 c4 0)
  222.       (repeat 10000
  223.          (setq i (roulette p))
  224.          (cond
  225.             ((= i 0)(setq c0 (1+ c0)))
  226.             ((= i 1)(setq c1 (1+ c1)))
  227.             ((= i 2)(setq c2 (1+ c2)))
  228.             ((= i 3)(setq c3 (1+ c3)))
  229.             ((= i 4)(setq c4 (1+ c4))) 
  230.          )     
  231.       )
  232.       ; Should return close to (2000 0 1500 6000 500)                         ;
  233.       (setq r (cons (list c0 c1 c2 c3 c4) r))
  234.    )
  235.    (reverse r)
  236. )
  237.  
  238.  
  239. ;; relcost     by ymg                                                         ;
  240. ;;                                                                            ;
  241. ;; Calculates Relative Cost of Solution                                       ;
  242. ;; From: Genetic Algorithms for Cutting Stock Problems:                       ;
  243. ;;       With and Without Contiguity.                                         ;
  244. ;; By Robert Hinterding & Lutfar Khan                                         ;
  245. ;;      http://vuir.vu.edu.au/25789/1/TECHNICALREPORT40_compressed.pdf        ;
  246. ;;                                                                            ;
  247. ;; ls is defined in main program                                              ;
  248.  
  249. (defun relcost (l / m)
  250.    (setq m (length l))
  251.    (/ (apply '+
  252.          (mapcar '(lambda (a) (+ (sqrt (/ (cadr a) (float ls)))
  253.                                  (/ (if (zerop (cadr a)) 0 1.0) m)
  254.                               )
  255.                   )
  256.                   l
  257.          )
  258.       )
  259.       (1+ m)
  260.    )
  261. )
  262.  
  263.  
  264.  
  265. ;; swapnth     by ymg                                                         ;
  266. ;;                                                                            ;
  267. ;; Given Two Indices, n1 and n2 and a List l.                                 ;
  268. ;; Returns the List with the Item Position Swapped                            ;
  269. ;;                                                                            ;
  270.  
  271. (defun swapnth (n1 n2 l / a d tmp)
  272.    (setq d (1- (length l))
  273.          a (vlax-safearray-fill (vlax-make-safearray vlax-vbinteger (cons 0 d)) l)
  274.        tmp (vlax-safearray-get-element a n1)
  275.    )
  276.    (vlax-safearray-put-element a n1 (vlax-safearray-get-element a n2))
  277.    (vlax-safearray-put-element a n2 tmp)
  278.    (vlax-safearray->list a)
  279. )
  280.  
  281. ;; swapnth     by CAB    (3 times faster than above)                          ;
  282. ;;                                                                            ;
  283. ;; Given Two Indices, n1 and n2 and a List l.                                 ;
  284. ;; Returns the List with the Item Position Swapped                            ;
  285. ;; Notes: I've removed the arguments testing.                                 ;
  286. ;; (if (and (< -1 i1 (length lst)) (< -1 i2 (length lst)))                    ;
  287.  
  288. (defun swapnth (n1 n2 l / i)
  289.    (setq i -1)
  290.    (mapcar '(lambda (a) (setq i (1+ i))
  291.                         (cond
  292.                            ((= i n2) (nth n1 l))
  293.                            ((= i n1) (nth n2 l))
  294.                            (a)
  295.                         )
  296.             )
  297.             l
  298.    )
  299. )
  300.  
  301.    
  302.  
  303. ; shuffle     (Original idea by highflyingbird)                               ;
  304. ;             Simplified the code   ymg                                       ;
  305.  
  306. (defun shuffle (l / a d  i  n tmp)
  307.    (setq d (1- (length l))
  308.          a (vlax-safearray-fill (vlax-make-safearray vlax-vbinteger (cons 0 d)) l)                    
  309.          i -1
  310.    )
  311.    (repeat d
  312.       (setq  i (1+ i)
  313.              n (+ i (fix (* (rand) (- d i))))  
  314.            tmp (vlax-safearray-get-element a n)
  315.       )
  316.       (vlax-safearray-put-element a n (vlax-safearray-get-element a i))
  317.       (vlax-safearray-put-element a i tmp)
  318.   )
  319.   (vlax-safearray->list a)
  320. )
  321.  
  322. ; This one by Irneb, list based. Actually quite fast, and even faster once    ;
  323. ; we replace repetitive call to function length by variable i                 ;
  324. ; in the vl-sort-i lambda clauses.                                            ;
  325.  
  326. (defun shuffle2 (l / p i)
  327.   (setq p (/ (setq i (length l)) 2))
  328.   (mapcar '(lambda (n) (nth n l))
  329.               (vl-sort-i l '(lambda (a b) (<= (fix (* (rand) i)) p)))))
  330.  
  331.  
  332.  
  333.  
  334. ;; mk_lwp    by Alan J Thompson                                                 ;
  335. ;; Argument: pl, A list of points (2d or 3d)                                    ;
  336. ;; Create an LWPolyline at Elevation 0, on Current Layer.                       ;
  337. ;; Return: Polyline Object                                                      ;
  338. ;;                                                                              ;
  339.  
  340. (defun mk_lwp (pl)
  341.     (vlax-ename->vla-object
  342.       (entmakex
  343.          (append (list '(0 . "LWPOLYLINE")
  344.                        '(100 . "AcDbEntity")
  345.                        '(100 . "AcDbPolyline")
  346.                         (cons 90 (length pl))
  347.                         '(70 . 0)
  348.                  )
  349.                  (mapcar '(lambda (p) (cons 10 (trans (list (car p) (cadr p)) 1 0))) pl)
  350.         )
  351.       )
  352.     )
  353.  )
  354.  
  355. ;; distinct#    by ymg  (Derived from Distinct by Gile Chanteau               ;
  356. ;; Returns a list of distinct Item and Quantity ((item qty)......)            ;
  357. ;; Argument                                                                   ;
  358. ;; l   List                                                                   ;
  359. ;;                                                                            ;
  360.  
  361. ;(defun distinct# (l)
  362. ;   (if l
  363. ;     (cons (cons (car l) (- (length l) (length (setq l (vl-remove (car l) l))))) (distinct# l))    
  364. ;   )
  365. ;)
  366.  
  367. ; Modified to return ((qty (pattern) waste) (...) (...))
  368. (defun distinct# (l / i)
  369.    (if l
  370.       (cons (cons (- (length l) (length (setq l (vl-remove (setq i (car l)) l)))) i) (distinct# l))    
  371.    )
  372. )
  373.  
  374. ; take   by ymg                                                               ;
  375. ;                                                                             ;
  376. ; Returns the first n items from a list as a list                             ;
  377. ;                                                                             ;
  378. ; Iterative version of Gile Chanteau's take                                   ;
  379.  
  380. (defun take (n l / r)
  381.    (repeat n
  382.       (setq r (cons (car l) r) l (cdr l))
  383.    )
  384.    (reverse r)
  385. )
  386.  
  387.  
  388. ;; printres                                                                   ;
  389. ;;                                                                            ;
  390. ;; Crude Patterns and Statistic Output to the Text Screen.                    ;
  391. ;;                                                                            ;
  392.  
  393. (defun printres (tit l d ls p / a su w)
  394.    ;(textscr)
  395.    (princ (strcat "\n" tit))
  396.    (princ (strcat "\n D: " (vl-princ-to-string d)))
  397.    (princ (strcat "\n L: " (vl-princ-to-string l)))
  398.    (princ (strcat "\nLs: " (if (= 'INT (type ls)) (itoa ls) (rtos ls 2 3))))
  399.    (princ "\n")
  400.    (foreach i p
  401.       (princ (strcat "\n" (vl-princ-to-string i)))
  402.    )
  403.    (princ "\n")
  404.    (princ (strcat "\nNb of Stock used    : " (itoa (setq su (apply '+ (mapcar 'car p))))))
  405.    (princ (strcat "\nNb of Parts Cut     : " (itoa (apply '+ (mapcar '(lambda (a) (* (car a) (length (cadr a)))) p)))))
  406.    (princ (strcat "\nTotal Length Wasted : " (if (= 'INT (type (setq w (apply '+ (mapcar '(lambda (a) (* (car a) (caddr a))) p))))) (itoa w) (rtos w 2 2))))
  407.    (princ (strcat "\nNb Patterns used    : " (itoa (length p))))
  408.    (princ (strcat "\nPercent Efficiency  : " (rtos (* 100 ( / (- (* su (float ls)) w) (* su ls))) 2 4) " %"))
  409.    (princ "\n\n")
  410. )
  411.  

ymg
« Last Edit: April 13, 2015, 11:18:11 AM by ymg »

serge_c

  • Newt
  • Posts: 39
Few lessons from Ymg mastermind !!! Should pattent this invention !!!  :)
You know I am gonna ask you again , if it's possible to help me , with my case (must be cutted per diameters ).
one more request : can you attach also your cvs file , mine is not working with your lisps anymore.
Thanks in advance .

ymg

  • Guest
sergiu,

Well not so "Mastermind" cause I believe I found
a huge bug in the above.

Although it converges toward a solution, the decoding
by ff-binpack is flawed.

I will address the by size once I have a solid solution
that also includes the contiguity constraints.

ymg

ymg

  • Guest
sergiu,

Turns out that I was wrong in above post.

The decoding is OK and respect the authors
way of doing it.

Where I do have a bug is when I create the initial
population, I wanted the first individual in the population
to be a First Fit Decreasing one.

This to bypass a series of useless solution.

However, my implementation is flawed.

Will revise and post again.

ymg

serge_c

  • Newt
  • Posts: 39
The world still wating, for the last version ; :)
We still have patience .. Don't  hury , do it good  !

roy_043

  • Water Moccasin
  • Posts: 1895
  • BricsCAD 18
Re: The Cutting Stock Problem (Optimizing Cutting of Rebar or Other Material)
« Reply #27 on: September 16, 2015, 04:14:31 AM »
Thank you Ymg for starting this thread. It has been on my 'Topics worth studying list' ever since.

Before reading this thread I have analysed the code by CAB and T.Willey linked to in the OP, and have tried to come up with my own algorithm for the problem. The results of my code are similar to those in the OP. So I have probably reinvented a wheel. I have yet to completely read this thread and check.

For reference my attempt:
Code - Auto/Visual Lisp: [Select]
  1. ; Testing with CAB's example.
  2. ; (c:Roy_Cut_Test)
  3. ;   => (
  4. ;        (44 (9.71) 101.2)
  5. ;        (23 (7.65 4.0) 8.28)
  6. ;        (10 (5.3 4.0 2.66) 0.5)
  7. ;        (29 (4.0 4.0 4.0) 0.29)
  8. ;        (19 (3.67 2.66 2.66 2.66) 6.84)
  9. ;        (11 (3.67 3.67 3.67) 11.0)
  10. ;        (1 (3.67 3.67) 4.67)
  11. ;      )
  12. ;
  13. ;      137 Standard lengths
  14. (defun c:Roy_Cut_Test ( / resLst standLen todoLst)
  15.   (setq standLen 12.01)
  16.   (setq todoLst '((23 7.65) (10 5.30) (54 3.67) (67 2.66) (44 9.71) (120 4.0)))
  17.   (setq todoLst (vl-sort todoLst '(lambda (a b) (> (cadr a) (cadr b)))))
  18.   (setq todoLst
  19.     (apply
  20.       'append
  21.       (mapcar
  22.         '(lambda (itm / lst) (repeat (car itm) (setq lst (cons (cadr itm) lst))))
  23.         todoLst
  24.       )
  25.     )
  26.   )
  27.   (setq resLst (Roy_Cut todoLst standLen))
  28.   (print resLst)
  29.   (princ
  30.     (strcat
  31.       "\n\n"
  32.       (itoa (apply '+ (mapcar 'car resLst)))
  33.       " Standard lengths "
  34.     )
  35.   )
  36.   (princ)
  37. )
  38.  
  39. ; (Roy_Cut '(9 9 3 2 2 2 2 1 1) 12)
  40. ; Format of return:
  41. ; ((numberOfOccurences (pattern as list of lengths) totalWaste) ...)
  42. (defun Roy_Cut (todoLst standLen / doneLst patternAndRest tmpLst)
  43.   (while todoLst
  44.     (setq patternAndRest
  45.       (car
  46.         (Roy_Cut_PatternsSort
  47.           (Roy_Cut_Patterns
  48.             (cdr todoLst)
  49.             (list (car todoLst))
  50.             (- standLen (car todoLst))
  51.           )
  52.         )
  53.       )
  54.     )
  55.     (setq tmpLst (Roy_Cut_RemovePattern todoLst (car patternAndRest)))
  56.     (setq doneLst
  57.       (cons
  58.         (list
  59.           (cadr tmpLst)        ; Number of occurences.
  60.           (car patternAndRest) ; Pattern.
  61.           (* (cadr tmpLst) (cadr patternAndRest)) ; Total waste.
  62.         )
  63.         doneLst
  64.       )
  65.     )
  66.     (setq todoLst (car tmpLst))
  67.   )
  68.   (reverse doneLst)
  69. )
  70.  
  71. ; (Roy_Cut_Patterns '(9 3 3 3 2 2 1) '(9) 3)
  72. ;   => (((9 3) 0) ((9 3) 0) ((9 3) 0) ((9 2 1) 0) ((9 2 1) 0) ((9 1 1) 1))
  73. (defun Roy_Cut_Patterns (todoLst doneLst rest)
  74.   (cond
  75.     (
  76.       (apply
  77.         'append
  78.         (mapcar
  79.           '(lambda (len)
  80.             (if (<= len rest)
  81.               (Roy_Cut_Patterns
  82.                 (setq todoLst (cdr todoLst))
  83.                 (append doneLst (list len))
  84.                 (- rest len)
  85.               )
  86.             )
  87.           )
  88.           todoLst
  89.         )
  90.       )
  91.     )
  92.     (
  93.       (list (list doneLst rest))
  94.     )
  95.   )
  96. )
  97.  
  98. ; (Roy_Cut_PatternsSort (Roy_Cut_Patterns '(9 3 3 3 2 2 1) '(9) 3))
  99. ;   => (((9 3) 0) ((9 2 1) 0) ((9 1 1) 1))
  100. (defun Roy_Cut_PatternsSort (lst)
  101.     (_List_DuplicateRemoveAll lst) ; Required.
  102.     '(lambda (a b)
  103.       (or
  104.         (< (cadr a) (cadr b)) ; Compare rest.
  105.         (and
  106.           (= (cadr a) (cadr b))
  107.           (< (length (car a)) (length (car b))) ; Compare number of lengths.
  108.         )
  109.       )
  110.     )
  111.   )
  112. )
  113.  
  114. ; (Roy_Cut_PatternIndexList '(9 9 3 3 3 2 2 1) '(3 2)) => (2 5)
  115. (defun Roy_Cut_PatternIndexList (todoLst pattern / idx idxLst)
  116.   (setq idx -1)
  117.   (if
  118.     (not
  119.       (vl-position
  120.         nil
  121.         (setq idxLst
  122.           (mapcar
  123.             '(lambda (itm / fndIdx)
  124.               (if (setq fndIdx (vl-position itm todoLst))
  125.                 (progn
  126.                   (setq todoLst (cdr (member itm todoLst)))
  127.                   (setq idx (+ fndIdx idx 1))
  128.                 )
  129.               )
  130.             )
  131.             pattern
  132.           )
  133.         )
  134.       )
  135.     )
  136.     idxLst
  137.   )
  138. )
  139.  
  140. ; Format of return:
  141. ; (newTodoLst numberOfOccurences)
  142. (defun Roy_Cut_RemovePattern (todoLst pattern / cnt idxLst)
  143.   (setq cnt 0)
  144.   (while (setq idxLst (Roy_Cut_PatternIndexList todoLst pattern))
  145.     (setq cnt (1+ cnt))
  146.     (setq todoLst (_List_IndexListRemove todoLst idxLst))
  147.   )
  148.   (list todoLst cnt)
  149. )
  150.  
  151. ;;; Library stuff:
  152.  
  153. ; (_List_DuplicateRemoveAll '(nil (1 1) nil (1 1) 3 5 6 7 3 7 7 3 nil)) => (NIL (1 1) 3 5 6 7)
  154. (defun _List_DuplicateRemoveAll (lst / ret)
  155.   (mapcar
  156.     '(lambda (itm) (if (not (vl-position itm ret)) (setq ret (cons itm ret))))
  157.     lst
  158.   )
  159.   (reverse ret)
  160. )
  161.  
  162. ; (_List_IndexListRemove '("a" "b" "c" "d" "e" "f") '(0 1 5)) => ("c" "d" "e")
  163. (defun _List_IndexListRemove (lst idxLst)
  164.   (apply ; A (vl-remove nil ...) structure is impossible here.
  165.     'append
  166.     (mapcar
  167.       '(lambda (idx itm) (if (not (vl-position idx idxLst)) (list itm)))
  168.       (_List_IndexSeqMakeLength (length lst))
  169.       lst
  170.     )
  171.   )
  172. )
  173.  
  174. ; Make a zero based list of integers.
  175. ; With speed improvement based on Reini Urban's (std-%setnth).
  176. ; (_List_IndexSeqMakeLength 7) => (0 1 2 3 4 5 6)
  177. (defun _List_IndexSeqMakeLength (len / ret)
  178.   (repeat (rem len 4)
  179.     (setq ret (cons (setq len (1- len)) ret))
  180.   )
  181.   (repeat (/ len 4)
  182.     (setq ret
  183.       (vl-list*
  184.         (- len 4)
  185.         (- len 3)
  186.         (- len 2)
  187.         (- len 1)
  188.         ret
  189.       )
  190.     )
  191.     (setq len (- len 4))
  192.   )
  193.   ret
  194. )
  195.  

roy_043

  • Water Moccasin
  • Posts: 1895
  • BricsCAD 18
Re: The Cutting Stock Problem (Optimizing Cutting of Rebar or Other Material)
« Reply #28 on: September 16, 2015, 02:32:13 PM »
First conclusion: Ymg's code is much more efficient than my poor attempt. In some cases my code even has memory issues...

ymg

  • Guest
Re: The Cutting Stock Problem (Optimizing Cutting of Rebar or Other Material)
« Reply #29 on: September 17, 2015, 04:51:18 AM »
roy,

The problem itself is quite hard, np hard as a matter of fact.

The algorithm by Dikili and Barlas works some of the time.
Binpack works also some of the time (More or less 90%)

The evolutive algorithm that I've proposed works quite well
but is much slower.  However in this particular example after
10000 generations and 1 hour of running time, it still had not found
the solution with 137 bars.  Would probably converge if I leave it
enough time.

ymg

roy_043

  • Water Moccasin
  • Posts: 1895
  • BricsCAD 18
Re: The Cutting Stock Problem (Optimizing Cutting of Rebar or Other Material)
« Reply #30 on: September 18, 2015, 10:35:31 AM »
@ Ymg:

As you have already explained the algorithm of your 1D-CSP function has some issues.

Because the processing occurs in sequence, the largest lengths are handled first, and is geared towards minimizing waste, an early pattern can use up lengths that make later, potentially more frequently used, patterns less efficient. Leading to a final result that is not always optimal.

I have looked at ways to improve the performance of 1D-CSP by changing the way the temporary list is sorted and ultimately have come up with the idea of introducing an 'Allowable Loss Factor' argument. This argument, in conjunction with the 'all' option of your GenPat, can be used to identify patterns with a high 'pattern count' that have a reasonable waste percentage. The processing still occurs step by step, but there no longer is a too strong emphasis on the largest demanded lengths.

The main function Alt-1D-CSP tries out several 'Allowable Loss Factors' and also tries the 'old behavior' of 1D-CSP and an FFD-BinPack solution. The best solution of 13 is returned.

Code - Auto/Visual Lisp: [Select]
  1. (defun Alt-1D-CSP (lenLst demLst stockLen)
  2.   (car
  3.     (vl-sort
  4.       (cons
  5.         (Alt-FFD-BinPack lenLst demLst stockLen)
  6.         (mapcar
  7.           '(lambda (okLossFact allPatP)
  8.             (1D-CSP lenLst demLst stockLen okLossFact allPatP)
  9.           )
  10.           '(0.000 0.000 0.005 0.010 0.015 0.020 0.025 0.030 0.035 0.040 0.045 0.050)
  11.           '(nil   T     T     T     T     T     T     T     T     T     T     T    )
  12.         )
  13.       )
  14.       '(lambda (a b) (< (car a) (car b))) ; Sort using loss factor.
  15.     )
  16.   )
  17. )

The results of Alt-1D-CSP appear to be quite good.

For example the efficiency percentages found for Problems 1a to 5a (EP-Cut.LSP) are identical to those found by your EP-CUT, and those for Problems 6a to 10a are higher. And EP-CUT usually suggests far more different patterns than Alt-1D-CSP.

Another example:
Quote
Problem 2 in post #7:
 Length list: (4.5 3.6 3.1 1.4 0.75)
 Demand list: (97 610 395 211 300)
Stock length: 12.000


Solution from a Commercial Program:
(2 (3.6 1.4 1.4 1.4 1.4 1.4 1.4) 0.0)
(1 (3.1 1.4 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75) 0.0)
(1 (0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75) 0.0)
(197 (3.6 3.1 3.1 1.4 0.75) 0.05)
(97 (4.5 3.6 3.6) 0.3)
(72 (3.6 3.6 3.6 0.75) 0.45)
(1 (3.6 1.4 0.75 0.75 0.75 0.75 0.75) 3.25)

Nb of Stock Used    : 371
Nb of Parts Cut     : 1613
Total Length Wasted : 74.60
Percent Efficiency  : 98.3243 %


Solution from Alt-1D-CSP:
(211 (3.6 3.6 3.1 1.4) 0.3)
(97 (4.5 3.6 3.1 0.75) 0.05)
(45 (3.6 3.6 3.1 0.75 0.75) 0.2)
(14 (3.1 3.1 3.1 0.75 0.75 0.75) 0.45)
(4 (0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75) 0.0)
(1 (3.6 0.75 0.75 0.75 0.75 0.75 0.75 0.75) 3.15)

Nb of Stock Used    : 372
Nb of Parts Cut     : 1613
Total Length Wasted : 86.600
Percent Efficiency  : 98.0600 %

I am attaching the Lisp code. As you will see I have renamed all variables as I find it hard to read code with many very short variable names. I hope you don't mind.

ymg

  • Guest
Re: The Cutting Stock Problem (Optimizing Cutting of Rebar or Other Material)
« Reply #31 on: September 18, 2015, 04:52:42 PM »
roy,

Look good to me, but will try to test it some more.

It sounds like an idea that I never followed which was
simply mixing the order of the pattern once an initial
solution was found.

Quote
As you will see I have renamed all variables as I find it hard to read code with many very short variable names.

I must be (I am  :-D)  old school as in my case me long name for variable mix me up.

On a side note Problems 1a to 4a are somewhat trivial.  Problems 5a to 10a are much
more challenging.

A lower number of patterns is a desirable feature.

Another feature which I have not adressed is the number of currently open lenght.
That is how many different pile of cut rods needs to be accumulated on the shop floor.

ymg

« Last Edit: September 18, 2015, 05:03:32 PM by ymg »

ymg

  • Guest
Re: The Cutting Stock Problem (Optimizing Cutting of Rebar or Other Material)
« Reply #32 on: September 22, 2015, 07:34:21 AM »
Roy,

I've done some testing.  Results are actually quite good,
better than anyhing I had up to now.

Problem 7 however waste 10 meter too much as opposed
to thiese solutions:

Quote
Real Cut 1D
(4   (3.6 1.4 1.4 1.4 1.4 1.4 1.4) 0.0)
(181 (3.6 3.1 3.1 1.4 0.75) 0.05)
(31  (3.6 3.6 3.1 0.75 0.75) 0.2)
(55  (3.6 3.6 3.6 0.75) 0.45)
(97  (4.5 3.6 3.6) 0.3)
(1   (3.1 3.1 0.75 0.75) 4.3)
(2   (3.6 3.6 1.4 1.4 1.4) 0.6)

Nb of Stock used   : 371
Nb of Parts Cut    : 1613
Total Length Wasted: 74.60
Percent Efficiency : 98.3243 %


CutLogic 1D
(2   (3.6 1.4 1.4 1.4 1.4 1.4 1.4) 0.0)
(1   (3.1 1.4 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75) 0.0)
(1   (0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75 0.75) 0.0)
(197 (3.6 3.1 3.1 1.4 0.75) 0.05)
(97  (4.5 3.6 3.6) 0.3)
(72  (3.6 3.6 3.6 0.75) 0.45)
(1   (3.6 1.4 0.75 0.75 0.75 0.75 0.75) 3.25)

Nb of Stock used:    371
Nb of Parts Cut    : 1613
Total Length Wasted: 74.60
Percent Efficiency : 98.3243 %

Probably due to the constraint on acceptable waste.

ymg

roy_043

  • Water Moccasin
  • Posts: 1895
  • BricsCAD 18
Re: The Cutting Stock Problem (Optimizing Cutting of Rebar or Other Material)
« Reply #33 on: September 22, 2015, 02:30:51 PM »
Relatively speaking the difference is small: only 0.26%. But there is definitely room for improvement. Where did you get this example and do you perhaps have other tough cases?

ymg

  • Guest
Re: The Cutting Stock Problem (Optimizing Cutting of Rebar or Other Material)
« Reply #34 on: September 22, 2015, 04:06:10 PM »
Roy,

Don't remember where I took this particular example.

Probably read too many papers.

But as a general rule, when all the demanded length are shorter
than 50% of the stock lenght, the problem tend to be difficult.

Another goal is to try to concentrate most of the loss in a single
pattern.  A case can be made that this can be reused in another
order.

ymg

roy_043

  • Water Moccasin
  • Posts: 1895
  • BricsCAD 18
Re: The Cutting Stock Problem (Optimizing Cutting of Rebar or Other Material)
« Reply #35 on: September 29, 2015, 03:04:09 PM »
I am still toying with this... :-)

I have discovered a problem with the genpat function. Fixed code below.

Test with old code:
Code: [Select]
(GenPat '(4.50 3.60 3.10 1.40 0.75) '(0 2 0 2 0) 12.0 nil)
=> ((0 2 0 2 0) (0 2 0 1 0) (0 2 0 0 0) (0 1 0 2 0) (0 1 0 1 0) (0 1 0 0 0))
(GenPat '(4.50 3.60 3.10 1.40 0.75) '(0 2 0 0 2) 12.0 nil)
=> ((0 2 0 0 2) (0 1 0 0 2))
(GenPat '(4.50 3.60 3.10 1.40 0.75) '(0 2 0 2 0) 12.0 T)
=> ((0 2 0 2 0) (0 2 0 1 0) (0 2 0 0 0) (0 1 0 2 0) (0 1 0 1 0) (0 1 0 0 0) (0 0 0 2 0) (0 0 0 1 0) (0 0 0 0 0))
(GenPat '(4.50 3.60 3.10 1.40 0.75) '(0 2 0 0 2) 12.0 T)
=> ((0 2 0 0 2) (0 1 0 0 2) (0 0 0 0 2))

Test with new code:
Code: [Select]
(GenPat '(4.50 3.60 3.10 1.40 0.75) '(0 2 0 2 0) 12.0 nil)
=> ((0 2 0 2 0) (0 2 0 1 0) (0 2 0 0 0) (0 1 0 2 0) (0 1 0 1 0) (0 1 0 0 0))
(GenPat '(4.50 3.60 3.10 1.40 0.75) '(0 2 0 0 2) 12.0 nil)
=> ((0 2 0 0 2) (0 2 0 0 1) (0 2 0 0 0) (0 1 0 0 2) (0 1 0 0 1) (0 1 0 0 0))
(GenPat '(4.50 3.60 3.10 1.40 0.75) '(0 2 0 2 0) 12.0 T)
=> ((0 2 0 2 0) (0 2 0 1 0) (0 2 0 0 0) (0 1 0 2 0) (0 1 0 1 0) (0 1 0 0 0) (0 0 0 2 0) (0 0 0 1 0))
(GenPat '(4.50 3.60 3.10 1.40 0.75) '(0 2 0 0 2) 12.0 T)
=> ((0 2 0 0 2) (0 2 0 0 1) (0 2 0 0 0) (0 1 0 0 2) (0 1 0 0 1) (0 1 0 0 0) (0 0 0 0 2) (0 0 0 0 1))

Code - Auto/Visual Lisp: [Select]
  1. ;; 20150929: Fixed by Roy.
  2. ;; 20150918: Very minor changes by Roy.
  3. ;; GenPat                    (By Ymg)                                         ;
  4. ;;                                                                            ;
  5. ;; http://www.theswamp.org/index.php?topic=48889.0                            ;
  6. ;;                                                                            ;
  7. ;; Procedure for Generating the Efficient Feasible Cutting Patterns           ;
  8. ;; http://www.cs.bham.ac.uk/~wbl/biblio/gecco2006/docs/p1675.pdf              ;
  9. ;; Appendix 1                                                                 ;
  10. ;; Part of "Cutting Stock Waste Reduction Using Genetic Algorithms"           ;
  11. ;;              by Y. Khalifa, O. Salem and A. Shahin                         ;
  12. ;;                                                                            ;
  13. ;; Argument: lenLst     List, Demanded Lengths in Descending Order.           ;
  14. ;;           demLst     List, Number of Corresponding Demanded Length.        ;
  15. ;;           stockLen   Real, Length of Standard Stock.                       ;
  16. ;;           allPatP    Boolean, if true,  Generate all Feasible Patterns.    ;
  17. ;;                               if false, Generate only the Set of Patterns  ;
  18. ;;                                         for the First Demand > 0.          ;
  19. (defun GenPat (lenLst demLst stockLen allPatP / i j cntLst maxIdx patLst usedLen)
  20.   (setq maxIdx (length lenLst))
  21.   (setq i 0)
  22.   (while (zerop (nth i demLst)) (setq i (1+ i)))
  23.   (while
  24.     (or
  25.       (not cntLst)
  26.       (if allPatP
  27.         (> (apply '+ cntLst) 0)
  28.         (> (nth i (reverse cntLst)) 0)
  29.       )
  30.     )
  31.     (cond
  32.       (cntLst
  33.         (while (zerop (car cntLst)) (setq cntLst (cdr cntLst))) ; Last item in cntLst is for the first item (= longest) in lenLst.
  34.         (setq cntLst (cons (1- (car cntLst)) (cdr cntLst)))
  35.         (setq j (length cntLst))
  36.         (setq usedLen
  37.           (apply
  38.             '+
  39.             (mapcar
  40.               '(lambda (cnt len) (* cnt len))
  41.               (reverse cntLst)
  42.               lenLst
  43.             )
  44.           )
  45.         )
  46.       )
  47.       (T
  48.         (setq j 0)
  49.         (setq usedLen 0.0)
  50.       )
  51.     )
  52.     (while (< j maxIdx)
  53.       (setq cntLst
  54.         (cons
  55.           (min
  56.             (fix (/ (- stockLen usedLen) (nth j lenLst)))
  57.             (nth j demLst)
  58.           )
  59.           cntLst
  60.         )
  61.       )
  62.       (setq usedLen (+ usedLen (* (car cntLst) (nth j lenLst))))
  63.       (setq j (1+ j))
  64.     )
  65.     (setq patLst (cons (reverse cntLst) patLst))
  66.   )
  67.   (reverse (cdr patLst)) ; Remove 'zero pattern'.
  68. )