(use eggdoc sxml-transforms srfi-13)

(define (s+ . rest) (string-concatenate (map ->string rest)))
(define (sw+ w lst) (string-intersperse (map ->string lst) w))

(define (make-lpx-parameter-doc name typ comment )
  (if (list? typ)
      (let ((variants (map cadr typ)))
	`(procedure ,(s+ "lpx:" name ":: LPX [ * (" (sw+ " | " variants) ")] -> LPX | VALUE")
		    ,comment))
      `(procedure ,(s+ "lpx:" name ":: LPX [ * " (string-upcase (->string typ)) "] -> LPX | VALUE")
		  ,comment)))

	 

(define doc
  `((eggdoc:begin
     (name "glpk")
     (description "GNU Linear Programming Kit (GLPK)")
     (author (url "http://chicken.wiki.br/users/ivan-raikov" "Ivan Raikov"))

     (history 
      (version "1.2" "Ported to Chicken 4")
      (version "1.1" "Added chicken-glpk.h to file manifest")
      (version "1.0" "Initial release"))

     (requires)

     (usage "(require-extension glpk)")

     (download "glpk.egg")

     (documentation
      
      (p (url "http://www.gnu.org/software/glpk/" "GLPK")
	 " is a package for solving linear programming and mixed integer programming problems. " )

      (p "The Chicken GLPK egg provides a Scheme interface to "
	 "a large subset of the GLPK procedures for problem setup and solving.  "
	 "Below is a list of procedures that are included in this egg, "
	 "along with brief descriptions. This egg has been tested with "
	 "GLPK version 4.28. ")

      (subsection "Problem constructors and predicates"

	  (procedure "lpx:empty-problem:: () -> LPX"
		     (p "This procedure creates a new problem that has no rows or columns."))

	  (procedure "lpx:make-problem:: DIR * PBOUNDS * XBOUNDS * OBJCOEFS * CONSTRAINTS * [ORDER] -> LPX"
		     ((p "This procedure creates a new problem with the specified parameters. ")
		     (ul 
		      (li "Argument " (tt "DIR") " specifies the optimization direction flag. It can be "
			  "one of " (tt "'maximize") " or  " (tt "'minimize") ". ")
		      (li "Argument " (tt "PBOUNDS") " is a list that specifies the type and bounds "
			  "for each row of the problem object. Each element of this list can take one "
			  "of the following forms: " 
			  (symbol-table 
			    (describe "'(unbounded)"  
				      ("Free (unbounded) variable, " (tt "-Inf <= x <= +Inf")))
			    (describe "'(lower-bound LB)" 
				      ("Variable with lower bound, " (tt "LB <= x <= +Inf")))
			    (describe "'(upper-bound UB)" 
				      ("Variable with upper bound, " (tt "-Inf <= x <= UB")))
			    (describe "'(double-bounded LB UB)" 
				      ("Double-bounded variable, " (tt "LB <= x <= UB")))
			    (describe "'(fixed LB UB)" 
				      ("Fixed variable, " (tt "LB = x = UB")))))
		      (li "Argument " (tt "XBOUNDS") " is a list that specifies the type and bounds "
			  "for each column (structural variable) of the problem object. "
			  "Each element of this list can take one of the forms described for parameter "
			  (tt "PBOUNDS") ". ")
		      (li "Argument " (tt "OBJCOEFS") " is a list that specifies the objective coefficients "
			  "for each column (structural variable). This list must be of the same length as "
			  (tt "XBOUNDS") ". ")
		      (li "Argument " (tt "OBJCOEFS") " is a list that specifies the objective coefficients "
			  "for each column (structural variable). ")
		      (li "Argument " (tt "CONSTRAINTS") " is an SRFI-4 " (tt "f64vector") " that represents "
			  "the problem's constraint matrix (in row-major or column-major order). ")
		      (li "Optional argument " (tt "ORDER") " specifies the element order of the constraints matrix. " 
			  "It can be one of " (tt "'row-major") " or " (tt "'column-major") ". ")
		      )))

	  (procedure "lpx?:: OBJECT -> BOOL"
		     (p "Returns true if the given object was created by " (tt "lpx:empty-problem") " or "
			(tt "lpx:make-problem") ", false otherwise. " ))


	  )  ;; end subsection
      

      (subsection "Problem accessors and modifiers"
		  
		  (procedure "lpx:set-problem-name:: LPX * NAME -> LPX"
			     "Sets problem name. ")
		  (procedure "lpx:get-problem-name:: LPX -> NAME"
			     "Returns the name of the given problem. ")
		  
		  (procedure "lpx:set-direction:: LPX * DIR -> LPX"
			     ("Specifies the optimization direction flag, which can be "
			      "one of " (tt "'maximize") " or  " (tt "'minimize") ". "))
		  (procedure "lpx:get-direction:: LPX -> DIR"
			     "Returns the optimization direction for the given problem. ")
		  
		  (procedure "lpx:set-class:: LPX * CLASS -> LPX"
			     ("Sets problem class (linear programming or mixed-integer programming. "
			      "Argument " (tt "CLASS") " can be one of " (tt "'lp") " or " (tt "'mip") ". "))

		  (procedure "lpx:get-class:: LPX -> CLASS"
			     "Returns the problem class. ")
		  
		  (procedure "lpx:add-rows:: LPX * N -> LPX"
			     ("This procedure adds " (tt "N") " rows (constraints) to the given problem. "
			      "Each new row is initially unbounded and has an empty list of constraint "
			      "coefficients. "))

		  (procedure "lpx:add-columns:: LPX * N -> LPX"
			     ("This procedure adds " (tt "N") " columns (structural variables) to the given problem. "))
		  
		  (procedure "lpx:set-row-name:: LPX * I * NAME -> LPX"
			     "Sets the name of row " (tt "I") ".")

		  (procedure "lpx:set-column-name:: LPX * J * NAME -> LPX"
			     "Sets the name of column " (tt "J") ".")

		  (procedure "lpx:get-row-name:: LPX * I -> NAME"
			     "Returns the name of row " (tt "I") ".")

		  (procedure "lpx:get-column-name:: LPX * J -> NAME"
			     "Returns the name of column " (tt "J") ".")

		  (procedure "lpx:get-num-rows:: LPX -> N"
			     "Returns the current number of rows in the given problem. ")

		  (procedure "lpx:get-num-columns:: LPX -> N"
			     "Returns the current number of columns in the given problem. ")

		  (procedure "lpx:set-row-bounds:: LPX * I * BOUNDS -> LPX"
			     ("Sets bounds for row " (tt "I") " in the given problem. "
			      "Argument " (tt "BOUNDS") " specifies the type and bounds "
			      "for the specified row. It can take one of the following forms: " 
			      (symbol-table 
			       (describe "'(unbounded)"  
					 ("Free (unbounded) variable, " (tt "-Inf <= x <= +Inf")))
			       (describe "'(lower-bound LB)" 
					 ("Variable with lower bound, " (tt "LB <= x <= +Inf")))
			       (describe "'(upper-bound UB)" 
					 ("Variable with upper bound, " (tt "-Inf <= x <= UB")))
			       (describe "'(double-bounded LB UB)" 
					 ("Double-bounded variable, " (tt "LB <= x <= UB")))
			       (describe "'(fixed LB UB)" 
					 ("Fixed variable, " (tt "LB = x = UB"))))))

		  (procedure "lpx:set-column-bounds:: LPX * J * BOUNDS -> LPX"
			     ("Sets bounds for column " (tt "J") " in the given problem. "
			      "Argument " (tt "BOUNDS") " specifies the type and bounds "
			      "for the specified column. It can take one of the following forms: " 
			      (symbol-table 
			       (describe "'(unbounded)"  
					 ("Free (unbounded) variable, " (tt "-Inf <= x <= +Inf")))
			       (describe "'(lower-bound LB)" 
					 ("Variable with lower bound, " (tt "LB <= x <= +Inf")))
			       (describe "'(upper-bound UB)" 
					 ("Variable with upper bound, " (tt "-Inf <= x <= UB")))
			       (describe "'(double-bounded LB UB)" 
					 ("Double-bounded variable, " (tt "LB <= x <= UB")))
			       (describe "'(fixed LB UB)" 
					 ("Fixed variable, " (tt "LB = x = UB"))))))

		  (procedure "lpx:set-objective-coefficient:: LPX * J * COEF -> LPX"
			     "Sets the objective coefficient at column " (tt "J") " (structural variable). ")
		  
		  (procedure "lpx:set-column-kind:: LPX * J * KIND -> LPX"
			     ("Sets the kind of column " (tt "J") " (structural variable). "
			      "Argument " (tt "KIND") " can be one of the following: "
			      (symbol-table
			       (describe "'iv" "integer variable")
			       (describe "'cv" "continuous variable"))))
			
		  (procedure "lpx:load-constraint-matrix:: LPX * F64VECTOR * NROWS * NCOLS [* ORDER] -> LPX"
			     ("Loads the constraint matrix for the given problem. "
			      "The constraints matrix is represented as an SRFI-4 " (tt "f64vector") 
			      " (in row-major or column-major order). "
			      "Optional argument " (tt "ORDER") 
			      " specifies the element order of the constraints matrix. " 
			      "It can be one of " (tt "'row-major") " or " (tt "'column-major") ". "))
			      
		  (procedure "lpx:get-column-primals:: LPX -> F64VECTOR"
			     "Returns the primal values of all structural variables (columns). ")

		  (procedure "lpx:get-objective-value:: LPX -> NUMBER"
			     "Returns the current value of the objective function. ")


		  ) ;; end subsection

      (subsection "Problem control parameters"

		  (p "The procedures in this section retrieve or set control parameters of GLPK problem object. "
		     "If a procedure is invoked only with a problem object as an argument, it will return "
		     "the value of its respective control parameter. If it is invoked with an additional argument, "
		     "that argument is used to set a new value for the control parameter. ")

		  
		  ,(make-lpx-parameter-doc
		    'message_level `((0 none) (1 error) (2 normal) (3 full))
		    "Level of messages output by solver routines."
		    )

		  ,(make-lpx-parameter-doc 
		    'scaling `((0 none) (1 equilibration) (2 geometric-mean) (3 geometric-mean+equilibration))
		    "Scaling option."
		    )

		  ,(make-lpx-parameter-doc 
		    'use_dual_simplex `bool
		    "Dual simplex option."
		    )
			
		  ,(make-lpx-parameter-doc 
		    'pricing `((0 textbook) (1 steepest-edge))
		    "Pricing option (for both primal and dual simplex)."
		    )

		  ,(make-lpx-parameter-doc 
		    'solution_rounding `bool
		    "Solution rounding option."
		    )

		  ,(make-lpx-parameter-doc 
		    'iteration_limit `int
		    "Simplex iteration limit."
		    )

		  ,(make-lpx-parameter-doc 
		    'iteration_count `int
		    "Simplex iteration count."
		    )

		  ,(make-lpx-parameter-doc 
		    'branching_heuristic `((0 first) (1 last) (2 driebeck+tomlin))
		    "Branching heuristic option (for MIP only)."
		    )

		  ,(make-lpx-parameter-doc 
		    'backtracking_heuristic `((0 dfs) (1 bfs) (2 best-projection) (3 best-local-bound))
		    "Backtracking heuristic option (for MIP only)."
		    )

		  ,(make-lpx-parameter-doc 
		    'use_presolver `bool
		    "Use the LP presolver."
		    )

		  ,(make-lpx-parameter-doc 
		    'relaxation `real
		    "Relaxation parameter used in the ratio test."
		    )
		  
		  ,(make-lpx-parameter-doc 
		    'time_limit `real
		    "Searching time limit, in seconds."
		    )


		  ) ;; end subsection

      (subsection "Scaling & solver procedures"
		  
		  (procedure "lpx:scale-problem:: LPX -> LPX"
			     ("This procedure performs scaling of of the constraints matrix in order "
			      "to improve its numerical properties. ")
			     )
		  
		  (procedure "lpx:simplex:: LPX -> STATUS"
			     ("This procedure solves the given LP problem using the simplex method.  "
			      "It can return one of the following status codes: "
			      (symbol-table
			       (describe "LPX_E_OK" "the LP problem has been successfully solved")

			       (describe "LPX_E_BADB" "Unable to start
the search, because the initial basis specified in the problem object
is invalid--the number of basic (auxiliary and structural) variables
is not the same as the number of rows in the problem object. ")

			       (describe "LPX_E_SING" "Unable to start
the search, because the basis matrix corresponding to the initial
basis is singular within the working precision. ")

			       (describe "LPX_E_COND" "Unable to start
the search, because the basis matrix corresponding to the initial
basis is ill-conditioned, i.e. its condition number is too large. ")

			       (describe "LPX_E_BOUND" "Unable to start
the search, because some double-bounded (auxiliary or structural)
variables have incorrect bounds. ")

			       (describe "LPX_E_FAIL" "The search was
prematurely terminated due to the solver failure. ")

			       (describe "LPX_E_OBJLL" "The search was
prematurely terminated, because the objective function being maximized
has reached its lower limit and continues decreasing (the dual simplex
only). ")

			       (describe "LPX_E_OBJUL" "The search was
prematurely terminated, because the objective function being minimized
has reached its upper limit and continues increasing (the dual simplex
only). ")

			       (describe "LPX_E_ITLIM" "The search was
prematurely terminated, because the simplex iteration limit has been
exceeded. ")

			       (describe "LPX_E_TMLIM" "The search was
prematurely terminated, because the time limit has been exceeded. ")

			       (describe "LPX_E_NOPFS" "The LP problem
instance has no primal feasible solution (only if the LP presolver is used). ")

			       (describe "LPX_E_NODFS" "The LP problem
instance has no dual feasible solution (only if the LP presolver is used)."))
				
			      ))


		  (procedure "lpx:integer:: LPX -> STATUS"
			     "Solves an MIP problem using the branch-and-bound method. ")

		  ) ;; end subsection

      )

     (examples (pre #<<EOF
;;
;; Two Mines Linear programming example from
;;
;; http://people.brunel.ac.uk/~mastjjb/jeb/or/basicor.html#twomines
;; 

;; Two Mines Company
;;
;; The Two Mines Company owns two different mines that produce an ore
;; which, after being crushed, is graded into three classes: high,
;; medium and low-grade. The company has contracted to provide a
;; smelting plant with 12 tons of high-grade, 8 tons of medium-grade
;; and 24 tons of low-grade ore per week. The two mines have different
;; operating characteristics as detailed below.
;; 
;; Mine    Cost per day ($'000)    Production (tons/day)                
;;                                High    Medium    Low
;; X       180                     6       3         4
;; Y       160                     1       1         6
;;
;;                                 Production (tons/week)
;;                                High    Medium    Low
;; Contract                       12       8        24
;;
;; How many days per week should each mine be operated to fulfill the
;; smelting plant contract?
;;

(require-extension srfi-4)
(require-extension glpk)

;; (1) Unknown variables
;;
;;      x = number of days per week mine X is operated
;;      y = number of days per week mine Y is operated
;;
;; (2) Constraints
;;
;;
;;    * ore production constraints - balance the amount produced with
;;      the quantity required under the smelting plant contract
;;
;;      High    6x + 1y >= 12
;;      Medium  3x + 1y >= 8
;;      Low     4x + 6y >= 24
;;
;; (3) Objective
;;
;;     The objective is to minimise cost which is given by 180x + 160y.
;;
;;     minimise  180x + 160y
;;     subject to
;;         6x + y >= 12
;;         3x + y >= 8
;;         4x + 6y >= 24
;;         x <= 5
;;         y <= 5
;;         x,y >= 0
;;
;; (4) Auxiliary variables (rows)
;;
;;  p = 6x + y
;;  q = 3x + y
;;  r = 4x + 6y
;;
;;  12 <= p < +inf
;;   8 <= q < +inf
;;  24 <= r < +inf

(define pbounds `((lower-bound 12) (lower-bound 8) (lower-bound 24)))

;; (5) Structural variables (columns)
;;
;;  0 <= x <= 5
;;  0 <= y <= 5

(define xbounds  `((double-bounded 0 5) (double-bounded 0 5)))

;; (6) Objective coefficients: 180, 160

(define objcoefs (list 180 160))


;; Constraints matrix (in row-major order)
;; 
;;   6  1   
;;   3  1   
;;   4  6   

(define constraints (f64vector 6 1 3 1 4 6))

;; Create the problem definition & run the solver
(let ((lpp (lpx:make-problem 'minimize pbounds xbounds objcoefs constraints)))
  (lpx:scale-problem lpp)
  (lpx:use_presolver lpp #t)
  (let ((status (lpx:simplex lpp)))
    (print "solution status = " status)
    (print "objective value = " (lpx:get-objective-value lpp))
    (print "primals = " (lpx:get-column-primals lpp))))

EOF
)
     (license
      "Copyright Ivan Raikov and the Okinawa Institute of Science and Technology.

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or (at
your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

A full copy of the GPL license can be found at
<http://www.gnu.org/licenses/>.")))))


(define glpk-eggdoc:css (make-parameter #<<EOF
 <!--
      CODE {
            color: #666666;
          }
/*   DT.definition EM { font-weight: bold; font-style: normal; } */

     DT.definition { 
                   background: #eee;
                   color: black;
                   padding: 0.2em 1em 0.2em 0.7em;
                   margin-left: 0.2em;
border: 1px solid #bbc;
                   font-family: "Andale Mono", monospace;
                   /* font-size: 1.2em; */
                   
                 }
     DD {
                   margin-top: 0.8em;
                   margin-bottom: 0.8em;
     }
     DIV.subsection {
                    border-top: 1px solid #448;
                    padding-left: 1em;
                    margin-bottom: 1.2em;
     }
     DIV.subsubsection {
                    border-top: 1px dotted #99c;
                    /* border-left: 1px solid #99c; */
                    padding-left: 1em;
                    margin-bottom: 1.2em;
     }
     DIV.subsubsubsection {
                    border-top: 1px solid #ddf;
                    padding-left: 1em;
                    margin-bottom: 1.2em;
     }

	 DIV.section {
		 margin-bottom: 1.5em;
	 }
	 a:link {
		 color: #336;
	 }
	 a:visited { color: #666; }
	 a:active  { color: #966; }
	 a:hover   { color: #669; }
	 body { margin: 0; padding: 0; background: #fff; color: #000; font: 9pt "Lucida Grande", "Verdana", sans-serif; }
	 H2 {
		 background: #336;
		 color: #fff;
		 padding-top: 0.5em;
		 padding-bottom: 0.5em;
		 padding-left: 16px;
		 margin: 0 0 1em 0;
	}
	UL LI {
		list-style: none;
	}
	TT {
		font-family: "Andale Mono", monospace;
		/* font-size: 1.2em; */
	}
	H3 {
		color: #113;
		margin-bottom: 0.5em;
	}
	H4, H5, H6 {
		color: #113;
		margin-bottom: 1.0em;
	}
	H5 {
		font-weight: normal;
                font-style: italic;
		font-size: 100%;
		margin-top: 1.2em;
	}
	H6 {
		font-weight: bold;
		font-size: 85%;
		margin-top: 1.2em;
	}
     DIV#eggheader {
         text-align: center;
		 float: right;
		 margin-right: 2em;
     }
     DIV#header IMG {
            /* display: block; margin-left: auto; margin-right: auto;  */
            /* float: right; */
            border: none;  /* firefox */
     }
     DIV#footer {
                background: #bbd;
                padding: 0.7em ;
                border-top: 1px solid #cce;
     }
     DIV#footer hr {
                display: none;
     }
     DIV#footer a {
                float: left;
     }
     DIV#revision-history {
         float: right;
     }
     
     DIV#body {
		 margin: 1em 1em 1em 16px;
	 }

     DIV#examples PRE {
       background: #eef;
       padding: 0.1em;
       border: 1px solid #aac;
     }
     PRE#license, DIV#examples PRE {
       padding: 0.5em;
     }
     DIV#examples PRE {
       /* font-size: 85%; */
     }
     PRE { font-family: "Andale Mono", monospace; }
     TABLE {
       background: #eef;
       padding: 0.2em;
       border: 1px solid #aac;
       border-collapse: collapse;
       width: 100%;
     }
     TABLE.symbol-table TD.symbol {
          width: 15em;
          font-family: "Andale Mono", monospace;
	  vertical-align: top;
          /* font-size: 1.2em; */
     }
     TABLE.symbol-table TD {
          font-family: "Andale Mono", monospace;
	  vertical-align: top;
          /* font-size: 1.2em; */
     }
     TH {
       text-align: left;
       border-bottom: 1px solid #aac;
       padding: 0.25em 0.5em 0.25em 0.5em;
     } 
     TD { padding: 0.25em 0.5em 0.25em 0.5em; }
     -->
EOF
))


(if (eggdoc->html doc 
   `( (eggdoc-style . ,(lambda (tag)
                         `("<style type=\"text/css\">" ,(glpk-eggdoc:css)
                           "</style>")))
      (documentation *macro* . ,(lambda (tag . elts)
				  (let* ((sections
					  (pre-post-order elts
							  `((subsection	;; (subsection level "content ...")
						   ((*text* . ,(lambda (tag str) str)))
						   . ,(lambda (tag head-word . elems)
							`(li (a (@ (href ,(string-append "#" head-word)))
								,head-word))))
						  (*default*
						   . ,(lambda (tag . elems) (list)))
						  
						  (*text* . ,(lambda (trigger str) (list))))))
			       (toc `(div (@ (class "toc"))
					  (ol ,sections))))
			  `(section "Documentation" ,(cons toc elts)))))
                      ,@(eggdoc:make-stylesheet doc) ))

    (void))