1signature GLUE_CALCULATION = 2sig 3 4 exception Rigid (* cannot stretch / shrink *) 5 6 val extractGlue: (BoxTypes.glueSpec -> (BasicTypes.dist * BoxTypes.infOrder)) -> 7 BoxTypes.node list -> (BasicTypes.dist * BoxTypes.infOrder) list 8 (* Given an access function (#stretch or #shrink), 9 the relevant glue information is extracted from a node list. *) 10 11 val addGlue: BoxTypes.infOrder -> (BasicTypes.dist * BoxTypes.infOrder) list -> BasicTypes.dist 12 (* This function adds up the glue values of the given infinity order. *) 13 14 val totalGlue: (BasicTypes.dist * BoxTypes.infOrder) list -> BasicTypes.dist * BoxTypes.infOrder 15 (* This function adds up the glue values in the list, 16 separately by the infOrder, 17 and returns the highest order where the sum does not cancel out to zero, 18 and this sum *) 19 20 val getGlueParam: BasicTypes.dist -> BoxTypes.node list -> BoxTypes.glueParam 21 (* computes the glue parameter resulting from changing the natural size 22 of the node list by the given amount *) 23end (* signature GLUE_CALCULATION *) 24(*----------*) 25 26structure GlueCalculation: GLUE_CALCULATION = 27struct 28 open BasicTypes; open BoxTypes 29 open Distance; open BasicBox 30 31 fun extractGlue access = 32 let fun extr [] = [] 33 | extr (Glue gs :: t) = access gs :: extr t 34 | extr (_ :: t) = extr t 35 in extr end 36 37 fun addGlue ord = 38 let fun add [] = zero 39 | add ((s, ord') :: t) = if ord = ord' then s + add t else add t 40 in add end 41 42 exception Rigid 43 44 fun totalGlue gl = 45 let fun checkGlue [] = raise Rigid 46 | checkGlue (ord :: rest) = 47 let val sum = addGlue ord gl 48 in if sum = zero then checkGlue rest else (sum, ord) end 49 in checkGlue [filll, fill, fil, normal] end 50 51 fun getGlueParam dw nl = 52 (if dw > zero then 53 let val (str, order) = totalGlue (extractGlue #stretch nl) 54 in stretching ( (real dw) / real str, order ) end 55 else if dw < zero then 56 let val (shr, order) = totalGlue (extractGlue #shrink nl) 57 in shrinking ( ~(real dw) / real shr, order ) end 58 else natural 59 ) 60 handle Rigid => natural 61 62end (* structure GlueCalculation *) 63